X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1b268608e34eadbdffb161f7125b67bfc0f2fcad..99f74b09f61407826aeb0bf8eabad6e2e628c02b:/op.c diff --git a/op.c b/op.c index 6776dc7..163b6a8 100644 --- a/op.c +++ b/op.c @@ -109,6 +109,24 @@ 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) +/* remove any leading "empty" ops from the op_next chain whose first + * node's address is stored in op_p. Store the updated address of the + * first node in op_p. + */ + +STATIC void +S_prune_chain_head(OP** op_p) +{ + while (*op_p + && ( (*op_p)->op_type == OP_NULL + || (*op_p)->op_type == OP_SCOPE + || (*op_p)->op_type == OP_SCALAR + || (*op_p)->op_type == OP_LINESEQ) + ) + *op_p = (*op_p)->op_next; +} + + /* See the explanatory comments above struct opslab in op.h. */ #ifdef PERL_DEBUG_READONLY_OPS @@ -145,6 +163,10 @@ S_new_slab(pTHX_ size_t sz) #else OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); #endif +#ifndef WIN32 + /* The context is unused in non-Windows */ + PERL_UNUSED_CONTEXT; +#endif slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1); return slab; } @@ -158,7 +180,6 @@ S_new_slab(pTHX_ size_t sz) void * Perl_Slab_Alloc(pTHX_ size_t sz) { - dVAR; OPSLAB *slab; OPSLAB *slab2; OPSLOT *slot; @@ -173,7 +194,10 @@ Perl_Slab_Alloc(pTHX_ size_t sz) don't use a slab, but allocate the OP directly from the heap. */ if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) - return PerlMemShared_calloc(1, sz); + { + o = (OP*)PerlMemShared_calloc(1, sz); + goto gotit; + } /* While the subroutine is under construction, the slabs are accessed via CvSTART(), to avoid needing to expand PVCV by one pointer for something @@ -198,17 +222,17 @@ Perl_Slab_Alloc(pTHX_ size_t sz) if (slab->opslab_freed) { OP **too = &slab->opslab_freed; o = *too; - DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab)); while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { DEBUG_S_warn((aTHX_ "Alas! too small")); o = *(too = &o->op_next); - if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); } + if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); } } if (o) { *too = o->op_next; Zero(o, opsz, I32 *); o->op_slabbed = 1; - return (void *)o; + goto gotit; } } @@ -253,7 +277,13 @@ Perl_Slab_Alloc(pTHX_ size_t sz) < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) slot = &slab2->opslab_slots; INIT_OPSLOT; - DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); + + gotit: + /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */ + o->op_lastsib = 1; + assert(!o->op_sibling); + return (void *)o; } @@ -311,7 +341,6 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) void Perl_Slab_Free(pTHX_ void *op) { - dVAR; OP * const o = (OP *)op; OPSLAB *slab; @@ -329,14 +358,13 @@ Perl_Slab_Free(pTHX_ void *op) o->op_type = OP_FREED; o->op_next = slab->opslab_freed; slab->opslab_freed = o; - DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab)); OpslabREFCNT_dec_padok(slab); } void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) { - dVAR; const bool havepad = !!PL_comppad; PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { @@ -350,10 +378,10 @@ Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) void Perl_opslab_free(pTHX_ OPSLAB *slab) { - dVAR; OPSLAB *slab2; PERL_ARGS_ASSERT_OPSLAB_FREE; - DEBUG_S_warn((aTHX_ "freeing slab %p", slab)); + PERL_UNUSED_CONTEXT; + DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); assert(slab->opslab_refcnt == 1); for (; slab; slab = slab2) { slab2 = slab->opslab_next; @@ -362,7 +390,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) #endif #ifdef PERL_DEBUG_READONLY_OPS DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", - slab)); + (void*)slab)); if (munmap(slab, slab->opslab_size * sizeof(I32 *))) { perror("munmap failed"); abort(); @@ -468,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -490,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -515,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -537,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + SV * const namesv = cv_name((CV *)gv, NULL); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -549,8 +547,6 @@ S_no_bareword_allowed(pTHX_ OP *o) { PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; - if (PL_madskills) - return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", SVfARG(cSVOPo_sv))); @@ -562,7 +558,6 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { - dVAR; PADOFFSET off; const bool is_our = (PL_parser->in_my == KEY_our); @@ -625,6 +620,8 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) } /* +=head1 Optree Manipulation Functions + =for apidoc alloccopstash Available only under threaded builds, this function allocates an entry in @@ -672,10 +669,21 @@ S_op_destroy(pTHX_ OP *o) /* Destructor */ +/* +=for apidoc Am|void|op_free|OP *o + +Free an op. Only use this when an op is no longer linked to from any +optree. + +=cut +*/ + void Perl_op_free(pTHX_ OP *o) { +#ifdef USE_ITHREADS dVAR; +#endif OPCODE type; /* Though ops may be freed twice, freeing the op after its slab is a @@ -687,6 +695,11 @@ Perl_op_free(pTHX_ OP *o) return; type = o->op_type; + + /* an op should only ever acquire op_private flags that we know about. + * If this fails, you may need to fix something in regen/op_private */ + assert(!(o->op_private & ~PL_op_private_valid[type])); + if (o->op_private & OPpREFCOUNTED) { switch (type) { case OP_LEAVESUB: @@ -721,7 +734,7 @@ Perl_op_free(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { - nextkid = kid->op_sibling; /* Get before next freeing kid */ + nextkid = OP_SIBLING(kid); /* Get before next freeing kid */ op_free(kid); } } @@ -753,19 +766,9 @@ Perl_op_clear(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_CLEAR; -#ifdef PERL_MAD - mad_free(o->op_madprop); - o->op_madprop = 0; -#endif - - retry: switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ - if (PL_madskills && o->op_targ != OP_NULL) { - o->op_type = (Optype)o->op_targ; - o->op_targ = 0; - goto retry; - } + /* FALLTHROUGH */ case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; @@ -774,7 +777,7 @@ Perl_op_clear(pTHX_ OP *o) if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != Perl_ck_ftst)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: @@ -804,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - /* No GvIN_PAD_off(cGVOPo_gv) here, because other references - * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } @@ -846,7 +847,7 @@ Perl_op_clear(pTHX_ OP *o) case OP_REDO: if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { @@ -872,14 +873,12 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - /* No GvIN_PAD_off here, because other references may still - * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_MATCH: case OP_QR: clear_pmop: @@ -981,11 +980,20 @@ S_find_and_forget_pmops(pTHX_ OP *o) forget_pmop((PMOP*)kid); } find_and_forget_pmops(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); } } } +/* +=for apidoc Am|void|op_null|OP *o + +Neutralizes an op when it is no longer needed, but is still linked to from +other ops. + +=cut +*/ + void Perl_op_null(pTHX_ OP *o) { @@ -995,8 +1003,7 @@ Perl_op_null(pTHX_ OP *o) if (o->op_type == OP_NULL) return; - if (!PL_madskills) - op_clear(o); + op_clear(o); o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; @@ -1005,7 +1012,9 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } @@ -1013,11 +1022,221 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } + +/* +=for apidoc op_sibling_splice + +A general function for editing the structure of an existing chain of +op_sibling nodes. By analogy with the perl-level splice() function, allows +you to delete zero or more sequential nodes, replacing them with zero or +more different nodes. Performs the necessary op_first/op_last +housekeeping on the parent node and op_sibling manipulation on the +children. The last deleted node will be marked as as the last node by +updating the op_sibling or op_lastsib field as appropriate. + +Note that op_next is not manipulated, and nodes are not freed; that is the +responsibility of the caller. It also won't create a new list op for an +empty list etc; use higher-level functions like op_append_elem() for that. + +parent is the parent node of the sibling chain. + +start is the node preceding the first node to be spliced. Node(s) +following it will be deleted, and ops will be inserted after it. If it is +NULL, the first node onwards is deleted, and nodes are inserted at the +beginning. + +del_count is the number of nodes to delete. If zero, no nodes are deleted. +If -1 or greater than or equal to the number of remaining kids, all +remaining kids are deleted. + +insert is the first of a chain of nodes to be inserted in place of the nodes. +If NULL, no nodes are inserted. + +The head of the chain of deleted ops is returned, or NULL if no ops were +deleted. + +For example: + + action before after returns + ------ ----- ----- ------- + + P P + splice(P, A, 2, X-Y-Z) | | B-C + A-B-C-D A-X-Y-Z-D + + P P + splice(P, NULL, 1, X-Y) | | A + A-B-C-D X-Y-B-C-D + + P P + splice(P, NULL, 3, NULL) | | A-B-C + A-B-C-D D + + P P + splice(P, B, 0, X-Y) | | NULL + A-B-C-D A-B-X-Y-C-D + +=cut +*/ + +OP * +Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) +{ + OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first; + OP *rest; + OP *last_del = NULL; + OP *last_ins = NULL; + + PERL_ARGS_ASSERT_OP_SIBLING_SPLICE; + + assert(del_count >= -1); + + if (del_count && first) { + last_del = first; + while (--del_count && OP_HAS_SIBLING(last_del)) + last_del = OP_SIBLING(last_del); + rest = OP_SIBLING(last_del); + OP_SIBLING_set(last_del, NULL); + last_del->op_lastsib = 1; + } + else + rest = first; + + if (insert) { + last_ins = insert; + while (OP_HAS_SIBLING(last_ins)) + last_ins = OP_SIBLING(last_ins); + OP_SIBLING_set(last_ins, rest); + last_ins->op_lastsib = rest ? 0 : 1; + } + else + insert = rest; + + if (start) { + OP_SIBLING_set(start, insert); + start->op_lastsib = insert ? 0 : 1; + } + else + cLISTOPx(parent)->op_first = insert; + + if (!rest) { + /* update op_last etc */ + U32 type = parent->op_type; + OP *lastop; + + if (type == OP_NULL) + type = parent->op_targ; + type = PL_opargs[type] & OA_CLASS_MASK; + + lastop = last_ins ? last_ins : start ? start : NULL; + if ( type == OA_BINOP + || type == OA_LISTOP + || type == OA_PMOP + || type == OA_LOOP + ) + cLISTOPx(parent)->op_last = lastop; + + if (lastop) { + lastop->op_lastsib = 1; +#ifdef PERL_OP_PARENT + lastop->op_sibling = parent; +#endif + } + } + return last_del ? first : NULL; +} + +/* +=for apidoc op_parent + +returns the parent OP of o, if it has a parent. Returns NULL otherwise. +(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to +work. + +=cut +*/ + +OP * +Perl_op_parent(OP *o) +{ + PERL_ARGS_ASSERT_OP_PARENT; +#ifdef PERL_OP_PARENT + while (OP_HAS_SIBLING(o)) + o = OP_SIBLING(o); + return o->op_sibling; +#else + PERL_UNUSED_ARG(o); + return NULL; +#endif +} + + +/* replace the sibling following start with a new UNOP, which becomes + * the parent of the original sibling; e.g. + * + * op_sibling_newUNOP(P, A, unop-args...) + * + * P P + * | becomes | + * A-B-C A-U-C + * | + * B + * + * where U is the new UNOP. + * + * parent and start args are the same as for op_sibling_splice(); + * type and flags args are as newUNOP(). + * + * Returns the new UNOP. + */ + +OP * +S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) +{ + OP *kid, *newop; + + kid = op_sibling_splice(parent, start, 1, NULL); + newop = newUNOP(type, flags, kid); + op_sibling_splice(parent, start, 0, newop); + return newop; +} + + +/* lowest-level newLOGOP-style function - just allocates and populates + * the struct. Higher-level stuff should be done by S_new_logop() / + * newLOGOP(). This function exists mainly to avoid op_first assignment + * being spread throughout this file. + */ + +LOGOP * +S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) +{ + LOGOP *logop; + OP *kid = first; + NewOp(1101, logop, 1, LOGOP); + logop->op_type = (OPCODE)type; + logop->op_first = first; + logop->op_other = other; + logop->op_flags = OPf_KIDS; + while (kid && OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); + if (kid) { + kid->op_lastsib = 1; +#ifdef PERL_OP_PARENT + kid->op_sibling = (OP*)logop; +#endif + } + return logop; +} + + /* Contextualizers */ /* @@ -1042,15 +1261,13 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) default: Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", (long) context); - return o; } } /* -=head1 Optree Manipulation Functions =for apidoc Am|OP*|op_linklist|OP *o -This function is the implementation of the L macro. It should +This function is the implementation of the L macro. It should not be called directly. =cut @@ -1073,9 +1290,10 @@ Perl_op_linklist(pTHX_ OP *o) o->op_next = LINKLIST(first); kid = first; for (;;) { - if (kid->op_sibling) { - kid->op_next = LINKLIST(kid->op_sibling); - kid = kid->op_sibling; + OP *sibl = OP_SIBLING(kid); + if (sibl) { + kid->op_next = LINKLIST(sibl); + kid = sibl; } else { kid->op_next = o; break; @@ -1093,7 +1311,7 @@ S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } return o; @@ -1102,8 +1320,6 @@ S_scalarkids(pTHX_ OP *o) STATIC OP * S_scalarboolean(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_SCALARBOOLEAN; if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST @@ -1123,10 +1339,124 @@ S_scalarboolean(pTHX_ OP *o) return scalar(o); } +static SV * +S_op_varname(pTHX_ const OP *o) +{ + assert(o); + assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || + o->op_type == OP_PADHV || o->op_type == OP_RV2HV); + { + const char funny = o->op_type == OP_PADAV + || o->op_type == OP_RV2AV ? '@' : '%'; + if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) { + GV *gv; + 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(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1); + } +} + +static void +S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) +{ /* or not so pretty :-) */ + if (o->op_type == OP_CONST) { + *retsv = cSVOPo_sv; + if (SvPOK(*retsv)) { + SV *sv = *retsv; + *retsv = sv_newmortal(); + pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); + } + else if (!SvOK(*retsv)) + *retpv = "undef"; + } + else *retpv = "..."; +} + +static void +S_scalar_slice_warning(pTHX_ const OP *o) +{ + OP *kid; + const char lbrack = + o->op_type == OP_HSLICE ? '{' : '['; + const char rbrack = + o->op_type == OP_HSLICE ? '}' : ']'; + SV *name; + SV *keysv = NULL; /* just to silence compiler warnings */ + const char *key = NULL; + + if (!(o->op_private & OPpSLICEWARNING)) + return; + if (PL_parser && PL_parser->error_count) + /* This warning can be nonsensical when there is a syntax error. */ + return; + + kid = cLISTOPo->op_first; + kid = OP_SIBLING(kid); /* get past pushmark */ + /* weed out false positives: any ops that can return lists */ + switch (kid->op_type) { + case OP_BACKTICK: + case OP_GLOB: + case OP_READLINE: + case OP_MATCH: + case OP_RV2AV: + case OP_EACH: + case OP_VALUES: + case OP_KEYS: + case OP_SPLIT: + case OP_LIST: + case OP_SORT: + case OP_REVERSE: + case OP_ENTERSUB: + case OP_CALLER: + case OP_LSTAT: + case OP_STAT: + case OP_READDIR: + case OP_SYSTEM: + case OP_TMS: + case OP_LOCALTIME: + case OP_GMTIME: + case OP_ENTEREVAL: + case OP_REACH: + case OP_RKEYS: + case OP_RVALUES: + return; + } + + /* Don't warn if we have a nulled list either. */ + if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) + return; + + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); + if (!name) /* XS module fiddling with the op tree */ + return; + S_op_pretty(aTHX_ kid, &keysv, &key); + assert(SvPOK(name)); + sv_chop(name,SvPVX(name)+1); + 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 + "%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", + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); +} + OP * Perl_scalar(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1146,10 +1476,10 @@ Perl_scalar(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalar(kid); break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SPLIT: case OP_MATCH: case OP_QR: @@ -1157,7 +1487,7 @@ Perl_scalar(pTHX_ OP *o) case OP_NULL: default: if (o->op_flags & OPf_KIDS) { - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } break; @@ -1165,10 +1495,10 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1185,6 +1515,46 @@ Perl_scalar(pTHX_ OP *o) case OP_SORT: Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; + case OP_KVHSLICE: + case OP_KVASLICE: + { + /* Warn about scalar context */ + const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '['; + const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']'; + SV *name; + SV *keysv; + const char *key = NULL; + + /* This warning can be nonsensical when there is a syntax error. */ + if (PL_parser && PL_parser->error_count) + break; + + if (!ckWARN(WARN_SYNTAX)) break; + + kid = cLISTOPo->op_first; + kid = OP_SIBLING(kid); /* get past pushmark */ + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); + if (!name) /* XS module fiddling with the op tree */ + break; + S_op_pretty(aTHX_ kid, &keysv, &key); + assert(SvPOK(name)); + sv_chop(name,SvPVX(name)+1); + 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", + 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", + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); + } } return o; } @@ -1201,21 +1571,6 @@ Perl_scalarvoid(pTHX_ OP *o) PERL_ARGS_ASSERT_SCALARVOID; - /* trailing mad null ops don't count as "there" for void processing */ - if (PL_madskills && - o->op_type != OP_NULL && - o->op_sibling && - o->op_sibling->op_type == OP_NULL) - { - OP *sib; - for (sib = o->op_sibling; - sib && sib->op_type == OP_NULL; - sib = sib->op_sibling) ; - - if (!sib) - return o; - } - if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE @@ -1243,7 +1598,7 @@ Perl_scalarvoid(pTHX_ OP *o) default: if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_REPEAT: if (o->op_flags & OPf_STACKED) break; @@ -1251,7 +1606,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SUBSTR: if (o->op_private == 4) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: @@ -1276,8 +1631,10 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_AELEMFAST: case OP_AELEMFAST_LEX: case OP_ASLICE: + case OP_KVASLICE: case OP_HELEM: case OP_HSLICE: + case OP_KVHSLICE: case OP_UNPACK: case OP_PACK: case OP_JOIN: @@ -1363,7 +1720,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_RV2AV: case OP_RV2HV: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && - (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) + (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE)) useless = "a variable"; break; @@ -1395,7 +1752,7 @@ Perl_scalarvoid(pTHX_ OP *o) SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { - useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv)); } else useless = "a constant (undef)"; @@ -1474,8 +1831,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_AND: kid = cLOGOPo->op_first; if (kid->op_type == OP_NOT - && (kid->op_flags & OPf_KIDS) - && !PL_madskills) { + && (kid->op_flags & OPf_KIDS)) { if (o->op_type == OP_AND) { o->op_type = OP_OR; o->op_ppaddr = PL_ppaddr[OP_OR]; @@ -1485,26 +1841,27 @@ Perl_scalarvoid(pTHX_ OP *o) } op_null(kid); } + /* FALLTHROUGH */ case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: case OP_ENTERWHEN: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; case OP_NULL: if (o->op_flags & OPf_STACKED) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: if (!(o->op_flags & OPf_KIDS)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: @@ -1513,7 +1870,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_LIST: case OP_LEAVEGIVEN: case OP_LEAVEWHEN: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; case OP_ENTEREVAL: @@ -1527,7 +1884,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* mortalise it, in case warnings are fatal. */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context", - sv_2mortal(useless_sv)); + SVfARG(sv_2mortal(useless_sv))); } else if (useless) { Perl_ck_warner(aTHX_ packWARN(WARN_VOID), @@ -1542,7 +1899,7 @@ S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) list(kid); } return o; @@ -1551,7 +1908,6 @@ S_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1578,7 +1934,7 @@ Perl_list(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) list(kid); break; default: @@ -1599,10 +1955,10 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1622,7 +1978,6 @@ Perl_list(pTHX_ OP *o) static OP * S_scalarseq(pTHX_ OP *o) { - dVAR; if (o) { const OPCODE type = o->op_type; @@ -1630,8 +1985,8 @@ S_scalarseq(pTHX_ OP *o) type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) { + if (OP_HAS_SIBLING(kid)) { scalarvoid(kid); } } @@ -1651,7 +2006,7 @@ S_modkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); } return o; @@ -1660,8 +2015,8 @@ S_modkids(pTHX_ OP *o, I32 type) /* =for apidoc finalize_optree -This function finalizes the optree. Should be called directly after -the complete optree is built. It does some additional +This function finalizes the optree. Should be called directly after +the complete optree is built. It does some additional checking which can't be done in the normal ck_xxx functions and makes the tree thread-safe. @@ -1685,23 +2040,6 @@ S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; -#if defined(PERL_MAD) && defined(USE_ITHREADS) - { - /* Make sure mad ops are also thread-safe */ - MADPROP *mp = o->op_madprop; - while (mp) { - if (mp->mad_type == MAD_OP && mp->mad_vlen) { - OP *prop_op = (OP *) mp->mad_val; - /* We only need "Relocate sv to the pad for thread safety.", but this - easiest way to make sure it traverses everything */ - if (prop_op->op_type == OP_CONST) - cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT; - finalize_op(prop_op); - } - mp = mp->mad_next; - } - } -#endif switch (o->op_type) { case OP_NEXTSTATE: @@ -1709,23 +2047,24 @@ S_finalize_op(pTHX_ OP* o) PL_curcop = ((COP*)o); /* for warnings */ break; case OP_EXEC: - if ( o->op_sibling - && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE) - && ckWARN(WARN_EXEC)) - { - if (o->op_sibling->op_sibling) { - const OPCODE type = o->op_sibling->op_sibling->op_type; + if (OP_HAS_SIBLING(o)) { + OP *sib = OP_SIBLING(o); + if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) + && ckWARN(WARN_EXEC) + && OP_HAS_SIBLING(sib)) + { + const OPCODE type = OP_SIBLING(sib)->op_type; if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { const line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling)); + CopLINE_set(PL_curcop, CopLINE((COP*)sib)); Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } - } } + } break; case OP_GV: @@ -1754,24 +2093,10 @@ S_finalize_op(pTHX_ OP* o) * for reference counts, sv_upgrade() etc. */ if (cSVOPo->op_sv) { const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY); - if (o->op_type != OP_METHOD_NAMED - && cSVOPo->op_sv == &PL_sv_undef) { - /* PL_sv_undef is hack - it's unsafe to store it in the - AV that is the pad, because av_fetch treats values of - PL_sv_undef as a "free" AV entry and will merrily - replace them with a new SV, causing pad_alloc to think - that this pad slot is free. (When, clearly, it is not) - */ - SvOK_off(PAD_SVl(ix)); - SvPADTMP_on(PAD_SVl(ix)); - SvREADONLY_on(PAD_SVl(ix)); - } - else { - SvREFCNT_dec(PAD_SVl(ix)); - PAD_SETSV(ix, cSVOPo->op_sv); - /* XXX I don't know how this isn't readonly already. */ - if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); - } + SvREFCNT_dec(PAD_SVl(ix)); + PAD_SETSV(ix, cSVOPo->op_sv); + /* XXX I don't know how this isn't readonly already. */ + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); cSVOPo->op_sv = NULL; o->op_targ = ix; } @@ -1782,66 +2107,40 @@ S_finalize_op(pTHX_ OP* o) UNOP *rop; SV *lexname; GV **fields; - SV **svp, *sv; - const char *key = NULL; - STRLEN keylen; + SVOP *key_op; + OP *kid; + bool check_fields; - if (((BINOP*)o)->op_last->op_type != OP_CONST) + if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST) break; - /* Make the CONST have a shared SV */ - svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvIsCOW_shared_hash(sv = *svp)) - && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) { - key = SvPV_const(sv, keylen); - lexname = newSVpvn_share(key, - SvUTF8(sv) ? -(I32)keylen : (I32)keylen, - 0); - SvREFCNT_dec_NN(sv); - *svp = lexname; - } + rop = (UNOP*)((BINOP*)o)->op_first; - if ((o->op_private & (OPpLVAL_INTRO))) - break; + goto check_keys; - rop = (UNOP*)((BINOP*)o)->op_first; - if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) - break; - lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!SvPAD_TYPED(lexname)) - break; - fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); - if (!fields || !GvHV(*fields)) + case OP_HSLICE: + S_scalar_slice_warning(aTHX_ o); + /* FALLTHROUGH */ + + case OP_KVHSLICE: + kid = OP_SIBLING(cLISTOPo->op_first); + if (/* I bet there's always a pushmark... */ + OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) + && OP_TYPE_ISNT_NN(kid, OP_CONST)) + { break; - key = SvPV_const(*svp, keylen); - if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { - Perl_croak(aTHX_ "No such class field \"%"SVf"\" " - "in variable %"SVf" of type %"HEKf, - SVfARG(*svp), SVfARG(lexname), - HEKfARG(HvNAME_HEK(SvSTASH(lexname)))); - } - break; - } + } + + key_op = (SVOP*)(kid->op_type == OP_CONST + ? kid + : OP_SIBLING(kLISTOP->op_first)); - case OP_HSLICE: { - UNOP *rop; - SV *lexname; - GV **fields; - SV **svp; - const char *key; - STRLEN keylen; - SVOP *first_key_op, *key_op; - - if ((o->op_private & (OPpLVAL_INTRO)) - /* I bet there's always a pushmark... */ - || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) - /* hmmm, no optimization if list contains only one key. */ - break; rop = (UNOP*)((LISTOP*)o)->op_last; - if (rop->op_type != OP_RV2HV) - break; - if (rop->op_first->op_type == OP_PADSV) + + check_keys: + if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV) + rop = NULL; + else if (rop->op_first->op_type == OP_PADSV) /* @$hash{qw(keys here)} */ rop = (UNOP*)rop->op_first; else { @@ -1852,26 +2151,38 @@ S_finalize_op(pTHX_ OP* o) rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; } else - break; + rop = NULL; } - lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE); - if (!SvPAD_TYPED(lexname)) - break; - fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE); - if (!fields || !GvHV(*fields)) - break; - /* Again guessing that the pushmark can be jumped over.... */ - first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) - ->op_first->op_sibling; - for (key_op = first_key_op; key_op; - key_op = (SVOP*)key_op->op_sibling) { + lexname = NULL; /* just to silence compiler warnings */ + fields = NULL; /* just to silence compiler warnings */ + + check_fields = + rop + && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE), + SvPAD_TYPED(lexname)) + && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE)) + && isGV(*fields) && GvHV(*fields); + for (; key_op; + key_op = (SVOP*)OP_SIBLING(key_op)) { + SV **svp, *sv; if (key_op->op_type != OP_CONST) continue; svp = cSVOPx_svp(key_op); - key = SvPV_const(*svp, keylen); - if (!hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) { + + /* Make the CONST have a shared SV */ + if ((!SvIsCOW_shared_hash(sv = *svp)) + && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) { + SSize_t keylen; + const char * const key = SvPV_const(sv, *(STRLEN*)&keylen); + SV *nsv = newSVpvn_share(key, + SvUTF8(sv) ? -keylen : keylen, 0); + SvREFCNT_dec_NN(sv); + *svp = nsv; + } + + if (check_fields + && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { Perl_croak(aTHX_ "No such class field \"%"SVf"\" " "in variable %"SVf" of type %"HEKf, SVfARG(*svp), SVfARG(lexname), @@ -1880,6 +2191,9 @@ S_finalize_op(pTHX_ OP* o) } break; } + case OP_ASLICE: + S_scalar_slice_warning(aTHX_ o); + break; case OP_SUBST: { if (cPMOPo->op_pmreplrootu.op_pmreplroot) @@ -1892,7 +2206,71 @@ S_finalize_op(pTHX_ OP* o) if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + +#ifdef DEBUGGING + /* check that op_last points to the last sibling, and that + * the last op_sibling field points back to the parent, and + * that the only ops with KIDS are those which are entitled to + * them */ + U32 type = o->op_type; + U32 family; + bool has_last; + + if (type == OP_NULL) { + type = o->op_targ; + /* ck_glob creates a null UNOP with ex-type GLOB + * (which is a list op. So pretend it wasn't a listop */ + if (type == OP_GLOB) + type = OP_NULL; + } + family = PL_opargs[type] & OA_CLASS_MASK; + + has_last = ( family == OA_BINOP + || family == OA_LISTOP + || family == OA_PMOP + || family == OA_LOOP + ); + assert( has_last /* has op_first and op_last, or ... + ... has (or may have) op_first: */ + || family == OA_UNOP + || family == OA_LOGOP + || family == OA_BASEOP_OR_UNOP + || family == OA_FILESTATOP + || family == OA_LOOPEXOP + /* 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 */ + ); + /* XXX list form of 'x' is has a null op_last. This is wrong, + * but requires too much hacking (e.g. in Deparse) to fix for + * now */ + if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) { + assert(has_last); + has_last = 0; + } + + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { +# ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(kid)) { + if (has_last) + assert(kid == cLISTOPo->op_last); + assert(kid->op_sibling == o); + } +# else + if (OP_HAS_SIBLING(kid)) { + assert(!kid->op_lastsib); + } + else { + assert(kid->op_lastsib); + if (has_last) + assert(kid == cLISTOPo->op_last); + } +# endif + } +#endif + + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) finalize_op(kid); } } @@ -1907,7 +2285,7 @@ because it has no op type of its own (it is signalled by a flag on the lvalue op). This function detects things that can't be modified, such as C<$x+1>, and -generates errors for them. For example, C<$x+1 = 2> would cause it to be +generates errors for them. For example, C<$x+1 = 2> would cause it to be called with an op of type OP_ADD and a C argument of OP_SASSIGN. It also flags things that need to behave specially in an lvalue context, @@ -1916,6 +2294,21 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>. =cut */ +static bool +S_vivifies(const OPCODE type) +{ + switch(type) { + case OP_RV2AV: case OP_ASLICE: + case OP_RV2HV: case OP_KVASLICE: + case OP_RV2SV: case OP_HSLICE: + case OP_AELEMFAST: case OP_KVHSLICE: + case OP_HELEM: + case OP_AELEM: + return 1; + } + return 0; +} + OP * Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { @@ -1942,16 +2335,13 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount++; return o; case OP_STUB: - if ((o->op_flags & OPf_PARENS) || PL_madskills) + if ((o->op_flags & OPf_PARENS)) break; goto nomod; case OP_ENTERSUB: if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ - /* Both ENTERSUB and RV2CV use this bit, but for different pur- - poses, so we need it clear. */ - o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ @@ -1969,6 +2359,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; + GV *gv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -1978,8 +2369,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } - while (kid->op_sibling) - kid = kid->op_sibling; + while (OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { break; /* Postpone until runtime */ } @@ -1996,14 +2387,19 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } - cv = GvCV(kGVOP_gv); + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; if (!cv) break; if (CvLVALUE(cv)) break; } } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: nomod: if (flags & OP_LVALUE_NO_CROAK) return NULL; @@ -2047,7 +2443,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COND_EXPR: localize = 1; - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); break; @@ -2057,24 +2453,33 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_RV2GV: if (scalar_mod_type(o, type)) goto nomod; ref(cUNOPo->op_first, o->op_type); - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_ASLICE: case OP_HSLICE: localize = 1; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_AASSIGN: - if (type == OP_LEAVESUBLV) + /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ + if (type == OP_LEAVESUBLV && ( + (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) + || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR + )) o->op_private |= OPpMAYBE_LVSUB; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; break; + case OP_KVHSLICE: + case OP_KVASLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + goto nomod; case OP_AV2ARYLEN: PL_hints |= HINT_BLOCK_SCOPE; if (type == OP_LEAVESUBLV) @@ -2084,9 +2489,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); localize = 1; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GV: PL_hints |= HINT_BLOCK_SCOPE; + /* FALLTHROUGH */ case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: @@ -2107,9 +2513,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; - if (type == OP_LEAVESUBLV) + if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR + && type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PADSV: PL_modcount++; if (!type) /* local() */ @@ -2129,14 +2536,14 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_SUBSTR: if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ goto nomod; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_POS: case OP_VEC: lvalue_func: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; if (o->op_flags & OPf_KIDS) - op_lvalue(cBINOPo->op_first->op_sibling, type); + op_lvalue(OP_SIBLING(cBINOPo->op_first), type); break; case OP_AELEM: @@ -2151,8 +2558,11 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount++; break; - case OP_SCOPE: case OP_LEAVE: + case OP_LEAVELOOP: + o->op_private |= OPpLVALUE; + /* FALLTHROUGH */ + case OP_SCOPE: case OP_ENTER: case OP_LINESEQ: localize = 0; @@ -2170,10 +2580,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) op_lvalue(cBINOPo->op_first, type); break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_LIST: localize = 0; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) /* elements might be in void context because the list is in scalar context or because they are attribute sub calls */ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID ) @@ -2187,6 +2597,16 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COREARGS: return o; + + case OP_AND: + case OP_OR: + if (type == OP_LEAVESUBLV + || !S_vivifies(cLOGOPo->op_first->op_type)) + op_lvalue(cLOGOPo->op_first, type); + if (type == OP_LEAVESUBLV + || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type)) + op_lvalue(OP_SIBLING(cLOGOPo->op_first), type); + goto nomod; } /* [20011101.069] File test operators interpret OPf_REF to mean that @@ -2229,7 +2649,7 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_SASSIGN: if (o && o->op_type == OP_RV2GV) return FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: @@ -2281,7 +2701,7 @@ S_is_handle_constructor(const OP *o, I32 numargs) case OP_SOCKPAIR: if (numargs == 2) return TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ @@ -2301,7 +2721,7 @@ S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) ref(kid, type); } return o; @@ -2327,7 +2747,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; - o->op_private &= ~1; } else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -2339,14 +2758,14 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) break; case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) doref(kid, type, set_op_ref); break; case OP_RV2SV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ doref(cUNOPo->op_first, o->op_type, set_op_ref); - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PADSV: if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -2360,7 +2779,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) case OP_RV2HV: if (set_op_ref) o->op_flags |= OPf_REF; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_RV2GV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ @@ -2393,7 +2812,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) case OP_SCOPE: case OP_LEAVE: set_op_ref = FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_ENTER: case OP_LIST: if (!(o->op_flags & OPf_KIDS)) @@ -2410,7 +2829,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) STATIC OP * S_dup_attrlist(pTHX_ OP *o) { - dVAR; OP *rop; PERL_ARGS_ASSERT_DUP_ATTRLIST; @@ -2421,14 +2839,10 @@ S_dup_attrlist(pTHX_ OP *o) */ if (o->op_type == OP_CONST) rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); -#ifdef PERL_MAD - else if (o->op_type == OP_NULL) - rop = NULL; -#endif else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); rop = NULL; - for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) rop = op_append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, @@ -2441,13 +2855,11 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - dVAR; SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; PERL_ARGS_ASSERT_APPLY_ATTRS; /* fake up C */ - ENTER; /* need to protect against side-effects of 'use' */ #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" @@ -2461,13 +2873,11 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); - LEAVE; } STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { - dVAR; OP *pack, *imop, *arg; SV *meth, *stashsv, **svp; @@ -2481,7 +2891,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ - ENTER; /* need to protect against side-effects of 'use' */ /* Don't force the C if we don't need it. */ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) @@ -2489,7 +2898,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs(ATTRSMODULE), NULL); - LEAVE; /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); @@ -2567,10 +2975,119 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, attrs))); } +STATIC void +S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) +{ + OP *new_proto = NULL; + STRLEN pvlen; + char *pv; + OP *o; + + PERL_ARGS_ASSERT_MOVE_PROTO_ATTR; + + if (!*attrs) + return; + + o = *attrs; + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + new_proto = o; + *attrs = NULL; + } + } else if (o->op_type == OP_LIST) { + OP * lasto; + assert(o->op_flags & OPf_KIDS); + lasto = cLISTOPo->op_first; + assert(lasto->op_type == OP_PUSHMARK); + for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) { + if (o->op_type == OP_CONST) { + pv = SvPV(cSVOPo_sv, pvlen); + if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { + SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv)); + SV ** const tmpo = cSVOPx_svp(o); + SvREFCNT_dec(cSVOPo_sv); + *tmpo = tmpsv; + if (new_proto && ckWARN(WARN_MISC)) { + 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", + UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); + op_free(new_proto); + } + else if (new_proto) + op_free(new_proto); + new_proto = o; + /* excise new_proto from the list */ + op_sibling_splice(*attrs, lasto, 1, NULL); + o = lasto; + continue; + } + } + lasto = o; + } + /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs + would get pulled in with no real need */ + if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) { + op_free(*attrs); + *attrs = NULL; + } + } + + if (new_proto) { + SV *svname; + if (isGV(name)) { + svname = sv_newmortal(); + gv_efullname3(svname, name, NULL); + } + else if (SvPOK(name) && *SvPVX((SV *)name) == '&') + svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP); + else + svname = (SV *)name; + if (ckWARN(WARN_ILLEGALPROTO)) + (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE); + if (*proto && ckWARN(WARN_PROTOTYPE)) { + STRLEN old_len, new_len; + const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); + 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, + UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), + UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), + SVfARG(svname)); + } + if (*proto) + op_free(*proto); + *proto = new_proto; + } +} + +static void +S_cant_declare(pTHX_ OP *o) +{ + if (o->op_type == OP_NULL + && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS) + o = cUNOPo->op_first; + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", + o->op_type == OP_NULL + && o->op_flags & OPf_SPECIAL + ? "do block" + : OP_DESC(o), + PL_parser->in_my == KEY_our ? "our" : + PL_parser->in_my == KEY_state ? "state" : + "my")); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { - dVAR; I32 type; const bool stately = PL_parser && PL_parser->in_my == KEY_state; @@ -2580,14 +3097,10 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) return o; type = o->op_type; - if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { - (void)my_kid(cUNOPo->op_first, attrs, imopsp); - return o; - } if (type == OP_LIST) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) my_kid(kid, attrs, imopsp); return o; } else if (type == OP_UNDEF || type == OP_STUB) { @@ -2596,13 +3109,10 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); } else if (attrs) { GV * const gv = cGVOPx_gv(cUNOPo->op_first); + assert(PL_parser); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), @@ -2619,16 +3129,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); return o; } else if (attrs && type != OP_PUSHMARK) { HV *stash; + assert(PL_parser); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -2648,7 +3155,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { - dVAR; OP *rops; int maybe_scalar = 0; @@ -2681,7 +3187,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) { OP * const pushmark = lrops->op_first; - lrops->op_first = pushmark->op_sibling; + /* excise pushmark */ + op_sibling_splice(rops, NULL, 1, NULL); op_free(pushmark); } o = op_append_list(OP_LIST, o, rops); @@ -2721,20 +3228,12 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) ) ? (int)rtype : OP_MATCH]; 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( - (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 - ); + S_op_varname(aTHX_ left); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", - desc, name, name); + desc, SVfARG(name), SVfARG(name)); else { const char * const sample = (isary ? "@array" : "%hash"); @@ -2754,8 +3253,10 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) /* !~ doesn't make sense with /r, so error on it for now */ if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with s///r doesn't make sense"); if (rtype == OP_TRANSR && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with tr///r doesn't make sense"); ismatchop = (rtype == OP_MATCH || @@ -2832,7 +3333,7 @@ Perl_op_scope(pTHX_ OP *o) op_null(kid); /* The following deals with things like 'do {1 for 1}' */ - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) op_null(kid); @@ -2849,7 +3350,7 @@ Perl_op_unscope(pTHX_ OP *o) { if (o && o->op_type == OP_LINESEQ) { OP *kid = cLISTOPo->op_first; - for(; kid; kid = kid->op_sibling) + for(; kid; kid = OP_SIBLING(kid)) if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) op_null(kid); } @@ -2859,7 +3360,6 @@ Perl_op_unscope(pTHX_ OP *o) int Perl_block_start(pTHX_ int full) { - dVAR; const int retval = PL_savestack_ix; pad_block_start(full); @@ -2876,7 +3376,6 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); OP *o; @@ -2938,7 +3437,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) */ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; - for (;; kid = kid->op_sibling) { + for (;; kid = OP_SIBLING(kid)) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); @@ -2958,7 +3457,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) =for apidoc Aox||blockhook_register Register a set of hooks to be called when the Perl lexical scope changes -at compile time. See L. +at compile time. See L. =cut */ @@ -2974,7 +3473,6 @@ Perl_blockhook_register(pTHX_ BHK *hk) STATIC OP * S_newDEFSVOP(pTHX) { - dVAR; const PADOFFSET offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); @@ -2989,8 +3487,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { @@ -3021,6 +3517,7 @@ Perl_newPROG(pTHX_ OP *o) ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); + S_prune_chain_head(&PL_eval_start); LEAVE; PL_savestack_ix = i; } @@ -3065,6 +3562,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); + S_prune_chain_head(&PL_main_start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -3085,8 +3583,6 @@ Perl_newPROG(pTHX_ OP *o) OP * Perl_localize(pTHX_ OP *o, I32 lex) { - dVAR; - PERL_ARGS_ASSERT_LOCALIZE; if (o->op_flags & OPf_PARENS) @@ -3183,7 +3679,7 @@ S_op_integerize(pTHX_ OP *o) if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) { dVAR; - o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)]; + o->op_ppaddr = PL_ppaddr[++(o->op_type)]; } if (type == OP_NEGATE) @@ -3207,6 +3703,7 @@ S_fold_constants(pTHX_ OP *o) SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; + U8 oldwarn = PL_dowarn; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -3220,27 +3717,39 @@ S_fold_constants(pTHX_ OP *o) case OP_UC: case OP_LC: case OP_FC: +#ifdef USE_LOCALE_CTYPE + if (IN_LC_COMPILETIME(LC_CTYPE)) + goto nope; +#endif + break; case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: +#ifdef USE_LOCALE_COLLATE + if (IN_LC_COMPILETIME(LC_COLLATE)) + goto nope; +#endif + break; case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (IN_LOCALE_COMPILETIME) +#ifdef USE_LOCALE_NUMERIC + if (IN_LC_COMPILETIME(LC_NUMERIC)) goto nope; +#endif break; case OP_PACK: - if (!cLISTOPo->op_first->op_sibling - || cLISTOPo->op_first->op_sibling->op_type != OP_CONST) + if (!OP_HAS_SIBLING(cLISTOPo->op_first) + || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST) goto nope; { - SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling); + SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first)); if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; { const char *s = SvPVX_const(sv); while (s < SvEND(sv)) { - if (*s == 'p' || *s == 'P') goto nope; + if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; s++; } } @@ -3248,6 +3757,11 @@ S_fold_constants(pTHX_ OP *o) break; case OP_REPEAT: if (o->op_private & OPpREPEAT_DOLIST) goto nope; + break; + case OP_SREFGEN: + if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST + || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first))) + goto nope; } if (PL_parser && PL_parser->error_count) @@ -3284,19 +3798,16 @@ S_fold_constants(pTHX_ OP *o) 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: CALLRUNOPS(aTHX); sv = *(PL_stack_sp--); if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ -#ifdef PERL_MAD - /* Can't simply swipe the SV from the pad, because that relies on - the op being freed "real soon now". Under MAD, this doesn't - happen (see the #ifdef below). */ - sv = newSVsv(sv); -#else pad_swipe(o->op_targ, FALSE); -#endif } else if (SvTEMP(sv)) { /* grab mortal temp? */ SvREFCNT_inc_simple_void(sv); @@ -3320,6 +3831,7 @@ S_fold_constants(pTHX_ OP *o) Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } JMPENV_POP; + PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; PL_curcop = &PL_compiling; @@ -3330,20 +3842,20 @@ S_fold_constants(pTHX_ OP *o) if (ret) goto nope; -#ifndef PERL_MAD op_free(o); -#endif assert(sv); if (type == OP_STRINGIFY) SvPADTMP_off(sv); - else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv); + else if (!SvIMMORTAL(sv)) { + SvPADTMP_on(sv); + SvREADONLY_on(sv); + } if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else { - newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv)); - newop->op_folded = 1; + newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); + if (type != OP_STRINGIFY) newop->op_folded = 1; } - op_getmad(o,newop,'f'); return newop; nope: @@ -3355,7 +3867,7 @@ S_gen_constant_list(pTHX_ OP *o) { dVAR; OP *curop; - const I32 oldtmps_floor = PL_tmps_floor; + const SSize_t oldtmps_floor = PL_tmps_floor; SV **svp; AV *av; @@ -3363,9 +3875,11 @@ S_gen_constant_list(pTHX_ OP *o) if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ - PL_op = curop = LINKLIST(o); + curop = LINKLIST(o); o->op_next = 0; CALL_PEEP(curop); + S_prune_chain_head(&curop); + PL_op = curop; Perl_pp_pushmark(aTHX); CALLRUNOPS(aTHX); PL_op = curop; @@ -3379,35 +3893,41 @@ S_gen_constant_list(pTHX_ OP *o) o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in rpeep() */ - curop = ((UNOP*)o)->op_first; av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); + + /* replace subtree with an OP_CONST */ + curop = ((UNOP*)o)->op_first; + op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av)); + op_free(curop); + if (AvFILLp(av) != -1) for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) + { SvPADTMP_on(*svp); -#ifdef PERL_MAD - op_getmad(curop,o,'O'); -#else - op_free(curop); -#endif + SvREADONLY_on(*svp); + } LINKLIST(o); return list(o); } +/* convert o (and any siblings) into a list if not already, then + * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it + */ + 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); + o = force_list(o, 0); else o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); else { - OP * const kid2 = cLISTOPo->op_first->op_sibling; + OP * const kid2 = OP_SIBLING(cLISTOPo->op_first); if (kid2 && kid2->op_type == OP_COREARGS) { op_null(cLISTOPo->op_first); kid2->op_private |= OPpCOREARGS_PUSHMARK; @@ -3459,13 +3979,8 @@ Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) return newLISTOP(type, 0, first, last); } - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; + op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); + first->op_flags |= OPf_KIDS; return first; } @@ -3497,25 +4012,15 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) if (last->op_type != (unsigned)type) return op_append_elem(type, first, last); - ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first; + ((LISTOP*)first)->op_last->op_lastsib = 0; + OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; + ((LISTOP*)first)->op_last->op_lastsib = 1; +#ifdef PERL_OP_PARENT + ((LISTOP*)first)->op_last->op_sibling = first; +#endif first->op_flags |= (last->op_flags & OPf_KIDS); -#ifdef PERL_MAD - if (((LISTOP*)last)->op_first && first->op_madprop) { - MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop; - if (mp) { - while (mp->mad_next) - mp = mp->mad_next; - mp->mad_next = first->op_madprop; - } - else { - ((LISTOP*)last)->op_first->op_madprop = first->op_madprop; - } - } - first->op_madprop = last->op_madprop; - last->op_madprop = 0; -#endif S_op_destroy(aTHX_ last); @@ -3546,19 +4051,13 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (last->op_type == (unsigned)type) { if (type == OP_LIST) { /* already a PUSHMARK there */ - first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; - ((LISTOP*)last)->op_first->op_sibling = first; + /* insert 'first' after pushmark */ + op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first); if (!(first->op_flags & OPf_PARENS)) last->op_flags &= ~OPf_PARENS; } - else { - if (!(last->op_flags & OPf_KIDS)) { - ((LISTOP*)last)->op_last = first; - last->op_flags |= OPf_KIDS; - } - first->op_sibling = ((LISTOP*)last)->op_first; - ((LISTOP*)last)->op_first = first; - } + else + op_sibling_splice(last, NULL, 0, first); last->op_flags |= OPf_KIDS; return last; } @@ -3568,251 +4067,6 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) /* Constructors */ -#ifdef PERL_MAD - -TOKEN * -Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) -{ - TOKEN *tk; - Newxz(tk, 1, TOKEN); - tk->tk_type = (OPCODE)optype; - tk->tk_type = 12345; - tk->tk_lval = lval; - tk->tk_mad = madprop; - return tk; -} - -void -Perl_token_free(pTHX_ TOKEN* tk) -{ - PERL_ARGS_ASSERT_TOKEN_FREE; - - if (tk->tk_type != 12345) - return; - mad_free(tk->tk_mad); - Safefree(tk); -} - -void -Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) -{ - MADPROP* mp; - MADPROP* tm; - - PERL_ARGS_ASSERT_TOKEN_GETMAD; - - if (tk->tk_type != 12345) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Invalid TOKEN object ignored"); - return; - } - tm = tk->tk_mad; - if (!tm) - return; - - /* faked up qw list? */ - if (slot == '(' && - tm->mad_type == MAD_SV && - SvPVX((SV *)tm->mad_val)[0] == 'q') - slot = 'x'; - - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - token_getmad(tk,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; - mp = mp->mad_next; - } - else { - o->op_madprop = tm; - mp = o->op_madprop; - } - if (mp->mad_key == 'X') - mp->mad_key = slot; /* just change the first one */ - - tk->tk_mad = 0; - } - else - mad_free(tm); - Safefree(tk); -} - -void -Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) -{ - MADPROP* mp; - if (!from) - return; - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - op_getmad(from,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = newMADPROP(slot,MAD_OP,from,0); - } - else { - o->op_madprop = newMADPROP(slot,MAD_OP,from,0); - } - } -} - -void -Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) -{ - MADPROP* mp; - if (!from) - return; - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - op_getmad(from,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = newMADPROP(slot,MAD_OP,from,1); - } - else { - o->op_madprop = newMADPROP(slot,MAD_OP,from,1); - } - } - else { - PerlIO_printf(PerlIO_stderr(), - "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); - op_free(from); - } -} - -void -Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) -{ - MADPROP* tm; - if (!mp || !o) - return; - if (slot) - mp->mad_key = slot; - tm = o->op_madprop; - o->op_madprop = mp; - for (;;) { - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; -} - -void -Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) -{ - if (!o) - return; - addmad(tm, &(o->op_madprop), slot); -} - -void -Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) -{ - MADPROP* mp; - if (!tm || !root) - return; - if (slot) - tm->mad_key = slot; - mp = *root; - if (!mp) { - *root = tm; - return; - } - for (;;) { - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; -} - -MADPROP * -Perl_newMADsv(pTHX_ char key, SV* sv) -{ - PERL_ARGS_ASSERT_NEWMADSV; - - return newMADPROP(key, MAD_SV, sv, 0); -} - -MADPROP * -Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) -{ - MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP)); - mp->mad_next = 0; - mp->mad_key = key; - mp->mad_vlen = vlen; - mp->mad_type = type; - mp->mad_val = val; -/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ - return mp; -} - -void -Perl_mad_free(pTHX_ MADPROP* mp) -{ -/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ - if (!mp) - return; - if (mp->mad_next) - mad_free(mp->mad_next); -/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) - PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ - switch (mp->mad_type) { - case MAD_NULL: - break; - case MAD_PV: - Safefree(mp->mad_val); - break; - case MAD_OP: - if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ - op_free((OP*)mp->mad_val); - break; - case MAD_SV: - sv_free(MUTABLE_SV(mp->mad_val)); - break; - default: - PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); - break; - } - PerlMemShared_free(mp); -} - -#endif /* =head1 Optree construction @@ -3831,12 +4085,36 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } +/* promote o and any siblings to be a list if its not already; i.e. + * + * o - A - B + * + * becomes + * + * list + * | + * pushmark - o - A - B + * + * If nullit it true, the list op is nulled. + */ + static OP * -S_force_list(pTHX_ OP *o) -{ - if (!o || o->op_type != OP_LIST) +S_force_list(pTHX_ OP *o, bool nullit) +{ + if (!o || o->op_type != OP_LIST) { + OP *rest = NULL; + if (o) { + /* manually detach any siblings then add them back later */ + rest = OP_SIBLING(o); + OP_SIBLING_set(o, NULL); + o->op_lastsib = 1; + } o = newLISTOP(OP_LIST, 0, o, NULL); - op_null(o); + if (rest) + op_sibling_splice(o, cLISTOPo->op_last, 0, rest); + } + if (nullit) + op_null(o); return o; } @@ -3873,17 +4151,26 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - first->op_sibling = last; + OP_SIBLING_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); - pushop->op_sibling = first; + pushop->op_lastsib = 0; + OP_SIBLING_set(pushop, first); listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) listop->op_last = pushop; } + if (first) + first->op_lastsib = 0; + if (listop->op_last) { + listop->op_last->op_lastsib = 1; +#ifdef PERL_OP_PARENT + listop->op_last->op_sibling = (OP*)listop; +#endif + } return CHECKOP(type, listop); } @@ -3965,7 +4252,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) - first = force_list(first); + first = force_list(first, 1); NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)type; @@ -3973,6 +4260,12 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); + +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */ + first->op_sibling = (OP*)unop; +#endif + unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -4000,7 +4293,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; BINOP *binop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP || type == OP_SASSIGN || type == OP_NULL ); NewOp(1101, binop, 1, BINOP); @@ -4018,14 +4311,24 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - first->op_sibling = last; + OP_SIBLING_set(first, last); + first->op_lastsib = 0; } +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */ + last->op_sibling = (OP*)binop; +#endif + binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; - binop->op_last = binop->op_first->op_sibling; + binop->op_last = OP_SIBLING(binop->op_first); +#ifdef PERL_OP_PARENT + if (binop->op_last) + binop->op_last->op_sibling = (OP*)binop; +#endif return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -4050,13 +4353,8 @@ static int uvcompare(const void *a, const void *b) static OP * S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { - dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; SV * const rstr = -#ifdef PERL_MAD - (repl->op_type == OP_NULL) - ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : -#endif ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; @@ -4117,11 +4415,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) rend = r + len; } -/* There are several snags with this code on EBCDIC: - 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). - 2. scan_const() in toke.c has encoded chars in native encoding which makes - ranges at least in EBCDIC 0..255 range the bottom odd. -*/ +/* There is a snag with this code on EBCDIC: scan_const() in toke.c has + * encoded chars in native encoding which makes ranges in the EBCDIC 0..255 + * odd. */ if (complement) { U8 tmpbuf[UTF8_MAXBYTES+1]; @@ -4131,11 +4427,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) i = 0; transv = newSVpvs(""); while (t < tend) { - cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags); + cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags); t += ulen; - if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { t++; - cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags); + cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags); t += ulen; } else { @@ -4148,11 +4444,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) UV val = cp[2*j]; diff = val - nextmin; if (diff > 0) { - t = uvuni_to_utf8(tmpbuf,nextmin); + t = uvchr_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); if (diff > 1) { - U8 range_mark = UTF_TO_NATIVE(0xff); - t = uvuni_to_utf8(tmpbuf, val - 1); + U8 range_mark = ILLEGAL_UTF8_BYTE; + t = uvchr_to_utf8(tmpbuf, val - 1); sv_catpvn(transv, (char *)&range_mark, 1); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } @@ -4161,13 +4457,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (val >= nextmin) nextmin = val + 1; } - t = uvuni_to_utf8(tmpbuf,nextmin); + t = uvchr_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); { - U8 range_mark = UTF_TO_NATIVE(0xff); + U8 range_mark = ILLEGAL_UTF8_BYTE; sv_catpvn(transv, (char *)&range_mark, 1); } - t = uvuni_to_utf8(tmpbuf, 0x7fffffff); + t = uvchr_to_utf8(tmpbuf, 0x7fffffff); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (const U8*)SvPVX_const(transv); tlen = SvCUR(transv); @@ -4188,11 +4484,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); + tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); t += ulen; - if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ t++; - tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags); + tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); t += ulen; } else @@ -4202,11 +4498,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); + rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); r += ulen; - if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ + if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ r++; - rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags); + rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); r += ulen; } else @@ -4289,13 +4585,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) Safefree(tsave); Safefree(rsave); -#ifdef PERL_MAD - op_getmad(expr,o,'e'); - op_getmad(repl,o,'r'); -#else op_free(expr); op_free(repl); -#endif return o; } @@ -4380,13 +4671,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (grows) o->op_private |= OPpTRANS_GROWS; -#ifdef PERL_MAD - op_getmad(expr,o,'e'); - op_getmad(repl,o,'r'); -#else op_free(expr); op_free(repl); -#endif return o; } @@ -4417,13 +4703,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (IN_LOCALE_COMPILETIME) { +#ifdef USE_LOCALE_CTYPE + if (IN_LC_COMPILETIME(LC_CTYPE)) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - 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))) - { + else +#endif + if (IN_UNI_8_BIT) { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -4458,7 +4744,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } else { SV * const repointer = &PL_sv_undef; av_push(PL_regex_padav, repointer); - pmop->op_pmoffset = av_len(PL_regex_padav); + pmop->op_pmoffset = av_tindex(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } #endif @@ -4502,25 +4788,27 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; - while (kid->op_sibling != repl) - kid = kid->op_sibling; - kid->op_sibling = NULL; - cLISTOPx(expr)->op_last = kid; + while (OP_SIBLING(kid) != repl) + kid = OP_SIBLING(kid); + op_sibling_splice(expr, kid, 1, NULL); } /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ if (is_trans) { - OP* const oe = expr; - assert(expr->op_type == OP_LIST); - assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); - assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); - expr = cLISTOPx(oe)->op_last; - cLISTOPx(oe)->op_first->op_sibling = NULL; - cLISTOPx(oe)->op_last = NULL; - op_free(oe); + OP *first, *last; + + assert(expr->op_type == OP_LIST); + first = cLISTOPx(expr)->op_first; + last = cLISTOPx(expr)->op_last; + assert(first->op_type == OP_PUSHMARK); + assert(OP_SIBLING(first) == last); - return pmtrans(o, expr, repl); + /* cut 'last' from sibling chain, then free everything else */ + op_sibling_splice(expr, first, 1, NULL); + op_free(expr); + + return pmtrans(o, last, repl); } /* find whether we have any runtime or code elements; @@ -4533,11 +4821,11 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) has_code = 0; if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { has_code = 1; - assert(!o->op_next && o->op_sibling); - o->op_next = o->op_sibling; + assert(!o->op_next && OP_HAS_SIBLING(o)); + o->op_next = OP_SIBLING(o); } else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) is_compiletime = 0; @@ -4553,7 +4841,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { assert( !(o->op_flags & OPf_WANT)); @@ -4572,8 +4860,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first); /* skip ENTER */ assert(leaveop->op_first->op_type == OP_ENTER); - assert(leaveop->op_first->op_sibling); - o->op_next = leaveop->op_first->op_sibling; + assert(OP_HAS_SIBLING(leaveop->op_first)); + o->op_next = OP_SIBLING(leaveop->op_first); /* skip leave */ assert(leaveop->op_flags & OPf_KIDS); assert(leaveop->op_last->op_next == (OP*)leaveop); @@ -4591,6 +4879,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* have to peep the DOs individually as we've removed it from * the op_next chain */ CALL_PEEP(o); + S_prune_chain_head(&(o->op_next)); if (is_compiletime) /* runtime finalizes as part of finalizing whole tree */ finalize_optree(o); @@ -4637,11 +4926,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, rx_flags, pm->op_pmflags) ); -#ifdef PERL_MAD - op_getmad(expr,(OP*)pm,'e'); -#else op_free(expr); -#endif } else { /* compile-time pattern that includes literal code blocks */ @@ -4743,18 +5028,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) cv_targ = expr->op_targ; expr = newUNOP(OP_REFGEN, 0, expr); - expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); } - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_REGCOMP; + rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o); rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; - rcop->op_first = scalar(expr); - rcop->op_flags |= OPf_KIDS - | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) - | (reglist ? OPf_STACKED : 0); - rcop->op_private = 0; - rcop->op_other = o; + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); rcop->op_targ = cv_targ; /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ @@ -4777,19 +5057,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) if (repl) { OP *curop = repl; bool konst; - if (pm->op_pmflags & PMf_EVAL) { - if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end) - CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end); - } /* If we are looking at s//.../e with a single statement, get past the implicit do{}. */ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS - && cUNOPx(curop)->op_first->op_type == OP_SCOPE - && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { + && cUNOPx(curop)->op_first->op_type == OP_SCOPE + && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) + { + OP *sib; OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; - if (kid->op_type == OP_NULL && kid->op_sibling - && !kid->op_sibling->op_sibling) - curop = kid->op_sibling; + if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid)) + && !OP_HAS_SIBLING(sib)) + curop = sib; } if (curop->op_type == OP_CONST) konst = TRUE; @@ -4817,13 +5095,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) op_prepend_elem(o->op_type, scalar(repl), o); } else { - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_SUBSTCONT; + rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o); rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; - rcop->op_first = scalar(repl); - rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); @@ -4907,11 +5181,11 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; - padop->op_padix = pad_alloc(type, SVs_PADTMP); + padop->op_padix = + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); - SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -4938,12 +5212,9 @@ reference to it. OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dVAR; - PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS - GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); @@ -4989,18 +5260,10 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) return CHECKOP(type, pvop); } -#ifdef PERL_MAD -OP* -#else void -#endif Perl_package(pTHX_ OP *o) { - dVAR; SV *const sv = cSVOPo->op_sv; -#ifdef PERL_MAD - OP *pegop; -#endif PERL_ARGS_ASSERT_PACKAGE; @@ -5013,26 +5276,13 @@ Perl_package(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; -#ifndef PERL_MAD op_free(o); -#else - if (!PL_madskills) { - op_free(o); - return NULL; - } - - pegop = newOP(OP_NULL,0); - op_getmad(o,pegop,'P'); - return pegop; -#endif } void Perl_package_version( pTHX_ OP *v ) { - dVAR; U32 savehints = PL_hints; PERL_ARGS_ASSERT_PACKAGE_VERSION; PL_hints &= ~HINT_STRICT_VARS; @@ -5041,20 +5291,12 @@ Perl_package_version( pTHX_ OP *v ) op_free(v); } -#ifdef PERL_MAD -OP* -#else void -#endif Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { - dVAR; OP *pack; OP *imop; OP *veop; -#ifdef PERL_MAD - OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL; -#endif SV *use_version = NULL; PERL_ARGS_ASSERT_UTILIZE; @@ -5062,16 +5304,11 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) if (idop->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); - if (PL_madskills) - op_getmad(idop,pegop,'U'); - veop = NULL; if (version) { SV * const vesv = ((SVOP*)version)->op_sv; - if (PL_madskills) - op_getmad(version,pegop,'V'); if (!arg && !SvNIOKp(vesv)) { arg = version; } @@ -5096,8 +5333,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { - if (PL_madskills) - op_getmad(arg,pegop,'S'); imop = arg; /* no import on explicit () */ } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { @@ -5110,9 +5345,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) else { SV *meth; - if (PL_madskills) - op_getmad(arg,pegop,'A'); - /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); @@ -5182,14 +5414,10 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; -#ifdef PERL_MAD - return pegop; -#endif } /* @@ -5201,7 +5429,8 @@ 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 and not NULL, 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 @@ -5242,7 +5471,6 @@ Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { - dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); @@ -5274,7 +5502,8 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) * that it has a PL_parser to play with while doing that, and also * that it doesn't mess with any existing parser, by creating a tmp * new parser with lex_start(). This won't actually be used for much, - * since pp_require() will create another parser for the real work. */ + * since pp_require() will create another parser for the real work. + * The ENTER/LEAVE pair protect callers from any side effects of use. */ ENTER; SAVEVPTR(PL_curcop); @@ -5284,28 +5513,25 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) LEAVE; } +PERL_STATIC_INLINE OP * +S_new_entersubop(pTHX_ GV *gv, OP *arg) +{ + return newUNOP(OP_ENTERSUB, OPf_STACKED, + newLISTOP(OP_LIST, 0, arg, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv)))); +} + OP * Perl_dofile(pTHX_ OP *term, I32 force_builtin) { - dVAR; OP *doop; - GV *gv = NULL; + GV *gv; PERL_ARGS_ASSERT_DOFILE; - if (!force_builtin) { - gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE); - gv = gvp ? *gvp : NULL; - } - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - doop = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, term, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))))); + if (!force_builtin && (gv = gv_override("do", 2))) { + doop = S_new_entersubop(aTHX_ gv, term); } else { doop = newUNOP(OP_DOFILE, 0, scalar(term)); @@ -5333,8 +5559,8 @@ OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, - list(force_list(subscript)), - list(force_list(listval)) ); + list(force_list(subscript, 1)), + list(force_list(listval, 1)) ); } STATIC I32 @@ -5352,8 +5578,9 @@ S_is_list_assignment(pTHX_ const OP *o) flags = o->op_flags; type = o->op_type; if (type == OP_COND_EXPR) { - const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); - const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + OP * const sib = OP_SIBLING(cLOGOPo->op_first); + const I32 t = is_list_assignment(sib); + const I32 f = is_list_assignment(OP_SIBLING(sib)); if (t && f) return TRUE; @@ -5369,7 +5596,8 @@ S_is_list_assignment(pTHX_ const OP *o) if (type == OP_LIST || flags & OPf_PARENS || type == OP_RV2AV || type == OP_RV2HV || - type == OP_ASLICE || type == OP_HSLICE) + type == OP_ASLICE || type == OP_HSLICE || + type == OP_KVASLICE || type == OP_KVHSLICE) return TRUE; if (type == OP_PADAV || type == OP_PADHV) @@ -5390,7 +5618,7 @@ PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o) { OP *curop; - for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) { + for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); @@ -5473,7 +5701,6 @@ set as required. OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { - dVAR; OP *o; if (optype) { @@ -5494,14 +5721,16 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP *curop; bool maybe_common_vars = TRUE; + if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE) + left->op_private &= ~ OPpSLICEWARNING; + PL_modcount = 0; left = op_lvalue(left, OP_AASSIGN); - curop = list(force_list(left)); - o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); + curop = list(force_list(left, 1)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); o->op_private = (U8)(0 | (flags >> 8)); - if ((left->op_type == OP_LIST - || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) + if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) { OP* lop = ((LISTOP*)left)->op_first; maybe_common_vars = FALSE; @@ -5527,14 +5756,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) (state $a, my $b, our $c, $d, undef) = ... */ } } else if (lop->op_type == OP_UNDEF || - lop->op_type == OP_PUSHMARK) { + OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) { /* undef may be interesting in (state $a, undef, state $c) */ } else { /* Other ops in the list. */ maybe_common_vars = TRUE; } - lop = lop->op_sibling; + lop = OP_SIBLING(lop); } } else if ((left->op_private & OPpLVAL_INTRO) @@ -5580,7 +5809,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) LINKLIST(o); } - if (right && right->op_type == OP_SPLIT && !PL_madskills) { + if (right && right->op_type == OP_SPLIT) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { PMOP * const pm = (PMOP*)tmpop; @@ -5607,7 +5836,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) #endif tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - tmpop->op_sibling = NULL; /* don't free split */ + /* detach rest of siblings from o subtree, + * and free subtree */ + op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); right->op_next = tmpop->op_next; /* fix starting loc */ op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; @@ -5697,6 +5928,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif +#ifdef VMS + if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH; +#endif cop->op_next = (OP*)cop; cop->cop_seq = seq; @@ -5712,7 +5946,11 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) SAVEFREEPV(label); } - if (PL_parser && PL_parser->copline == NOLINE) + if (PL_parser->preambling != NOLINE) { + CopLINE_set(cop, PL_parser->preambling); + PL_parser->copline = NOLINE; + } + else if (PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { CopLINE_set(cop, PL_parser->copline); @@ -5725,11 +5963,11 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #endif CopSTASH_set(cop, PL_curstash); - if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { + if (cop->op_type == OP_DBSTATE) { /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { - SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); + SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); if (svp && *svp != &PL_sv_undef ) { (void)SvIOK_on(*svp); SvIV_set(*svp, PTR2IV(cop)); @@ -5759,8 +5997,6 @@ consumed by this function and become part of the constructed op tree. OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { - dVAR; - PERL_ARGS_ASSERT_NEWLOGOP; return new_logop(type, flags, &first, &other); @@ -5791,7 +6027,7 @@ S_search_const(pTHX_ OP *o) case OP_ENTER: case OP_NULL: case OP_NEXTSTATE: - kid = kid->op_sibling; + kid = OP_SIBLING(kid); break; default: if (kid != cLISTOPo->op_last) @@ -5825,6 +6061,44 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first = *firstp; other = *otherp; + /* [perl #59802]: Warn about things like "return $a or $b", which + is parsed as "(return $a) or $b" rather than "return ($a or + $b)". NB: This also applies to xor, which is why we do it + here. + */ + switch (first->op_type) { + case OP_NEXT: + case OP_LAST: + case OP_REDO: + /* XXX: Perhaps we should emit a stronger warning for these. + Even with the high-precedence operator they don't seem to do + anything sensible. + + But until we do, fall through here. + */ + case OP_RETURN: + case OP_EXIT: + case OP_DIE: + case OP_GOTO: + /* XXX: Currently we allow people to "shoot themselves in the + foot" by explicitly writing "(return $a) or $b". + + Warn unless we are looking at the result from folding or if + the programmer explicitly grouped the operators like this. + The former can occur with e.g. + + use constant FEATURE => ( $] >= ... ); + sub { not FEATURE and return or do_stuff(); } + */ + if (!first->op_folded && !(first->op_flags & OPf_PARENS)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Possible precedence issue with control flow operator"); + /* XXX: Should we optimze this to "return $a;" (i.e. remove + the "or $b" part)? + */ + break; + } + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); @@ -5836,7 +6110,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && (first->op_flags & OPf_KIDS) && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ - && !PL_madskills) { + ) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; @@ -5861,12 +6135,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; - if (PL_madskills) { - OP *newop = newUNOP(OP_NULL, 0, other); - op_getmad(first, newop, '1'); - newop->op_targ = type; /* set "was" field */ - return newop; - } op_free(first); if (other->op_type == OP_LEAVE) other = newUNOP(OP_NULL, OPf_SPECIAL, other); @@ -5876,8 +6144,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || other->op_type == OP_TRANS) /* Mark the op as being unbindable with =~ */ other->op_flags |= OPf_SPECIAL; - else if (other->op_type == OP_CONST) - other->op_private |= OPpCONST_FOLDED; other->op_folded = 1; return other; @@ -5888,7 +6154,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK - && (( o2 = o2->op_sibling)) ) + && (( o2 = OP_SIBLING(o2))) ) ) o2 = other; if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV @@ -5903,13 +6169,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) *otherp = NULL; if (cstop->op_type == OP_CONST) cstop->op_private |= OPpCONST_SHORTCIRCUIT; - if (PL_madskills) { - first = newUNOP(OP_NULL, 0, first); - op_getmad(other, first, '2'); - first->op_targ = type; /* set "was" field */ - } - else - op_free(other); + op_free(other); return first; } } @@ -5917,7 +6177,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { const OP * const k1 = ((UNOP*)first)->op_first; - const OP * const k2 = k1->op_sibling; + const OP * const k2 = OP_SIBLING(k1); OPCODE warnop = 0; switch (first->op_type) { @@ -5962,19 +6222,16 @@ 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 */ - NewOp(1101, logop, 1, LOGOP); - - logop->op_type = (OPCODE)type; + logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other)); logop->op_ppaddr = PL_ppaddr[type]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); - logop->op_other = LINKLIST(other); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = other; + assert(!OP_HAS_SIBLING(first)); + op_sibling_splice((OP*)logop, first, 0, other); CHECKOP(type,logop); @@ -6024,33 +6281,21 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) cstop->op_private & OPpCONST_STRICT) { no_bareword_allowed(cstop); } - if (PL_madskills) { - /* This is all dead code when PERL_MAD is not defined. */ - live = newUNOP(OP_NULL, 0, live); - op_getmad(first, live, 'C'); - op_getmad(dead, live, left ? 'e' : 't'); - } else { - op_free(first); - op_free(dead); - } + op_free(first); + op_free(dead); if (live->op_type == OP_LEAVE) live = newUNOP(OP_NULL, OPf_SPECIAL, live); else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST || live->op_type == OP_TRANS || live->op_type == OP_TRANSR) /* Mark the op as being unbindable with =~ */ live->op_flags |= OPf_SPECIAL; - else if (live->op_type == OP_CONST) - live->op_private |= OPpCONST_FOLDED; live->op_folded = 1; return live; } - NewOp(1101, logop, 1, LOGOP); - logop->op_type = OP_COND_EXPR; + logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); - logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ @@ -6060,8 +6305,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) start = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = trueop; - trueop->op_sibling = falseop; + /* make first, trueop, falseop siblings */ + op_sibling_splice((OP*)logop, first, 0, trueop); + op_sibling_splice((OP*)logop, trueop, 0, falseop); + o = newUNOP(OP_NULL, 0, (OP*)logop); trueop->op_next = falseop->op_next = o; @@ -6096,17 +6343,14 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) PERL_ARGS_ASSERT_NEWRANGE; - NewOp(1101, range, 1, LOGOP); - - range->op_type = OP_RANGE; + range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right)); range->op_ppaddr = PL_ppaddr[OP_RANGE]; - range->op_first = left; range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); - range->op_other = LINKLIST(right); range->op_private = (U8)(1 | (flags >> 8)); - left->op_sibling = right; + /* make left and right siblings */ + op_sibling_splice((OP*)range, left, 0, right); range->op_next = (OP*)range; flip = newUNOP(OP_FLIP, flags, (OP*)range); @@ -6158,16 +6402,23 @@ unused and should always be 1. OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dVAR; OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); + block->op_type == OP_NULL; PERL_UNUSED_ARG(debuggable); if (expr) { - if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + if (once && ( + (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + || ( expr->op_type == OP_NOT + && cUNOPx(expr)->op_first->op_type == OP_CONST + && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) + ) + )) + /* Return the block now, so that S_new_logop does not try to + fold it away. */ return block; /* do {} while 0 does once */ if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR @@ -6178,7 +6429,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = k1 ? k1->op_sibling : NULL; + const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6206,11 +6457,19 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); o = new_logop(OP_AND, 0, &expr, &listop); + if (once) { + ASSUME(listop); + } + if (listop) ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) + { + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; + } if (o == listop) o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ @@ -6268,7 +6527,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = (k1) ? k1->op_sibling : NULL; + const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6380,7 +6639,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADOFFSET padoff = 0; I32 iterflags = 0; I32 iterpflags = 0; - OP *madsv = NULL; PERL_ARGS_ASSERT_NEWFOROP; @@ -6403,12 +6661,8 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) else if (sv->op_type == OP_PADSV) { /* private variable */ iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ padoff = sv->op_targ; - if (PL_madskills) - madsv = sv; - else { - sv->op_targ = 0; - op_free(sv); - } + sv->op_targ = 0; + op_free(sv); sv = NULL; } else @@ -6432,8 +6686,9 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } iterpflags |= OPpITER_DEF; } + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { - expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); iterflags |= OPf_STACKED; } else if (expr->op_type == OP_NULL && @@ -6447,11 +6702,12 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; OP* const left = range->op_first; - OP* const right = left->op_sibling; + OP* const right = OP_SIBLING(left); LISTOP* listop; range->op_flags &= ~OPf_KIDS; - range->op_first = NULL; + /* detach range's children */ + op_sibling_splice((OP*)range, NULL, -1, NULL); listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); listop->op_first->op_next = range->op_next; @@ -6459,17 +6715,13 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) right->op_next = (OP*)listop; listop->op_next = listop->op_first; -#ifdef PERL_MAD - op_getmad(expr,(OP*)listop,'O'); -#else op_free(expr); -#endif expr = (OP*)(listop); op_null(expr); iterflags |= OPf_STACKED; } else { - expr = op_lvalue(force_list(expr), OP_GREPSTART); + expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); } loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, @@ -6485,6 +6737,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); +#ifdef PERL_OP_PARENT + assert(loop->op_last->op_sibling == (OP*)loop); + loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */ +#endif S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } @@ -6492,8 +6748,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); - if (madsv) - op_getmad(madsv, (OP*)loop, 'v'); return wop; } @@ -6511,7 +6765,6 @@ becomes part of the constructed op tree. OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dVAR; OP *o = NULL; PERL_ARGS_ASSERT_NEWLOOPEX; @@ -6546,11 +6799,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) /* If we have already created an op, we do not need the label. */ if (o) -#ifdef PERL_MAD - op_getmad(label,o,'L'); -#else op_free(label); -#endif else o = newUNOP(type, OPf_STACKED, label); PL_hints |= HINT_BLOCK_SCOPE; @@ -6573,7 +6822,9 @@ S_ref_array_or_hash(pTHX_ OP *cond) else if(cond && (cond->op_type == OP_ASLICE - || cond->op_type == OP_HSLICE)) { + || cond->op_type == OP_KVASLICE + || cond->op_type == OP_HSLICE + || cond->op_type == OP_KVHSLICE)) { /* anonlist now needs a list from this op, was previously used in * scalar context */ @@ -6608,25 +6859,22 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, PERL_ARGS_ASSERT_NEWGIVWHENOP; - NewOp(1101, enterop, 1, LOGOP); - enterop->op_type = (Optype)enter_opcode; + enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); enterop->op_ppaddr = PL_ppaddr[enter_opcode]; - enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); if (cond) { - enterop->op_first = scalar(cond); - cond->op_sibling = block; + /* prepend cond if we have one */ + op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); o->op_next = LINKLIST(cond); cond->op_next = (OP *) enterop; } else { /* This is a default {} block */ - enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; o ->op_flags |= OPf_SPECIAL; @@ -6657,8 +6905,6 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, STATIC bool S_looks_like_bool(pTHX_ const OP *o) { - dVAR; - PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { @@ -6667,9 +6913,13 @@ S_looks_like_bool(pTHX_ const OP *o) return looks_like_bool(cLOGOPo->op_first); case OP_AND: + { + OP* sibl = OP_SIBLING(cLOGOPo->op_first); + ASSUME(sibl); return ( looks_like_bool(cLOGOPo->op_first) - && looks_like_bool(cLOGOPo->op_first->op_sibling)); + && looks_like_bool(sibl)); + } case OP_NULL: case OP_SCALAR: @@ -6717,7 +6967,7 @@ S_looks_like_bool(pTHX_ const OP *o) else return FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ default: return FALSE; } @@ -6739,7 +6989,6 @@ be affected. If it is 0, the global $_ will be used. OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { - dVAR; PERL_ARGS_ASSERT_NEWGIVENOP; return newGIVWHENOP( ref_array_or_hash(cond), @@ -6780,12 +7029,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* must not conflict with SVf_UTF8 */ +#define CV_CKPROTO_CURSTASH 0x1 + void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { SV *name = NULL, *msg; - const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + const char * cvp = SvROK(cv) + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; @@ -6822,6 +7078,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, gv_efullname3(name = sv_newmortal(), gv, NULL); else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); @@ -6850,7 +7116,7 @@ static void const_av_xsub(pTHX_ CV* cv); =for apidoc cv_const_sv -If C is a constant sub eligible for inlining. returns the constant +If C is a constant sub eligible for inlining, returns the constant value returned by the sub. Otherwise, returns NULL. Constant subs can be created with C or as described in @@ -6859,10 +7125,9 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ const CV *const cv) +Perl_cv_const_sv(const CV *const cv) { SV *sv; - PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) @@ -6873,32 +7138,46 @@ Perl_cv_const_sv(pTHX_ const CV *const cv) } SV * -Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) +Perl_cv_const_sv_or_av(const CV * const cv) { - PERL_UNUSED_CONTEXT; if (!cv) return NULL; + if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. + * Can be called in 3 ways: + * + * !cv + * look for a single OP_CONST with attached value: return the value + * + * cv && CvCLONE(cv) && !CvCONST(cv) + * + * examine the clone prototype, and if contains only a single + * OP_CONST referencing a pad const, or a single PADSV referencing + * an outer lexical, return a non-zero value to indicate the CV is + * a candidate for "constizing" at clone time + * + * cv && CvCONST(cv) + * + * We have just cloned an anon prototype that was marked as a const + * candidate. Try to grab the current value, and in the case of + * PADSV, ignore it if it has multiple references. In this case we + * return a newly created *copy* of the value. */ SV * -Perl_op_const_sv(pTHX_ const OP *o) +Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { - dVAR; SV *sv = NULL; - if (PL_madskills) - return NULL; - if (!o) return NULL; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) - o = cLISTOPo->op_first->op_sibling; + o = OP_SIBLING(cLISTOPo->op_first); for (; o; o = o->op_next) { const OPCODE type = o->op_type; @@ -6919,6 +7198,31 @@ Perl_op_const_sv(pTHX_ const OP *o) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } + else if (cv && type == OP_CONST) { + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + if (!sv) + return NULL; + } + else if (cv && type == OP_PADSV) { + if (CvCONST(cv)) { /* newly cloned anon */ + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (!sv || SvREFCNT(sv) != 2) + return NULL; + sv = newSVsv(sv); + SvREADONLY_on(sv); + return sv; + } + else { + if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) + sv = &PL_sv_undef; /* an arbitrary non-null value */ + } + } else { return NULL; } @@ -6934,9 +7238,6 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, assert (o || name); assert (const_svp); if ((!block -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif )) { if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ @@ -6974,20 +7275,13 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, SvREFCNT_inc_simple_void_NN(PL_compcv); CopLINE_set(PL_curcop, oldline); } -#ifdef PERL_MAD - if (!PL_minus_c) /* keep old one around for madskills */ -#endif - { - /* (PL_madskills unset in used file.) */ - SvREFCNT_dec(cv); - } + SAVEFREESV(cv); return TRUE; } CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dVAR; CV **spot; SV **svspot; const char *ps; @@ -7025,6 +7319,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; spot = (CV **)svspot; + if (!(PL_parser && PL_parser->error_count)) + move_proto_attr(&proto, &attrs, (GV *)name); + if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); @@ -7033,12 +7330,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (!PL_madskills) { - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); - } + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); if (PL_parser && PL_parser->error_count) { op_free(block); @@ -7061,12 +7356,16 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvNAMED(*spot)) hek = CvNAME_HEK(*spot); else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); CvNAME_HEK_set(*spot, hek = share_hek( PadnamePV(name)+1, - PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0 + PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash ) ); + CvLEXICAL_on(*spot); } if (mg) { assert(mg->mg_obj); @@ -7081,13 +7380,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block || !ps || *ps || attrs || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS) -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7100,7 +7396,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8); /* already defined? */ if (exists) { - if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv)) + if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv)) cv = NULL; else { if (attrs) goto attrs; @@ -7132,8 +7428,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); - if (PL_madskills) - goto install_block; op_free(block); SvREFCNT_dec(compcv); PL_compcv = NULL; @@ -7154,9 +7448,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { /* must reuse cv in case stub is referenced elsewhere */ /* transfer PL_compcv to cv */ if (block -#ifdef PERL_MAD - && block->op_type != OP_NULL -#endif ) { cv_flags_t preserved_flags = CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); @@ -7201,14 +7492,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) *spot = cv; } setname: + CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - CvNAME_HEK_set(cv, - hek - ? share_hek_hek(hek) - : share_hek(PadnamePV(name)+1, + if (hek) (void)share_hek_hek(hek); + else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), - 0) - ); + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) goto clone; @@ -7220,7 +7515,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } - install_block: if (!block) goto attrs; @@ -7233,11 +7527,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { OP* const newblock = newSTATEOP(0, NULL, 0); -#ifdef PERL_MAD - op_getmad(block,newblock,'B'); -#else op_free(block); -#endif block = newblock; } CvROOT(cv) = CvLVALUE(cv) @@ -7254,11 +7544,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); 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); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ @@ -7328,17 +7625,11 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) return cv; } +/* _x = extended */ 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) +Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, bool o_is_gv) { - dVAR; GV *gv; const char *ps; STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ @@ -7349,37 +7640,41 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a - full GV and CV. If anything is present then it will take a full CV to + full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : - (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) - || PL_madskills) + (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; 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 && !o_is_gv && SvUTF8(cSVOPo->op_sv); #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; + bool special = FALSE; #endif - if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); - ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); - } - else - ps = NULL; - 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); + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : PL_curstash != CopSTASH(PL_curcop) + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7395,15 +7690,24 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); has_name = FALSE; } + if (!ec) + move_proto_attr(&proto, &attrs, + isGV(gv) ? gv : (GV *)cSVOPo->op_sv); - if (!PL_madskills) { - if (o) - SAVEFREEOP(o); - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); + if (proto) { + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } + else + ps = NULL; + + if (o) + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); if (ec) { op_free(block); @@ -7427,36 +7731,85 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, goto done; } - if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at - maximum a prototype before. */ + if (!block && SvTYPE(gv) != SVt_PVGV) { + /* If we are not defining a new sub and the existing one is not a + full GV + CV... */ + if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { + /* We are applying attributes to an existing sub, so we need it + upgraded if it is a constant. */ + if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_init_pvn(gv, PL_curstash, name, namlen, + SVf_UTF8 * name_is_utf8); + } + else { /* Maybe prototype now, and had at maximum + a prototype or const/sub ref before. */ if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8); } - if (ps) { + if (!SvROK(gv)) { + if (ps) { sv_setpvn(MUTABLE_SV(gv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); - } - else + } + else sv_setiv(MUTABLE_SV(gv), -1); + } SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; + } } - cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, 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); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %"SVf" redefined", + SVfARG(cSVOPo->op_sv)); + + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } + } if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7468,7 +7821,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ - if (exists || GvASSUMECV(gv)) { + if (exists || (isGV(gv) && GvASSUMECV(gv))) { if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { @@ -7492,14 +7845,23 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvISXSUB_on(cv); } else { - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); + if (isGV(gv)) { + if (name) GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } } - if (PL_madskills) - goto install_block; op_free(block); SvREFCNT_dec(PL_compcv); PL_compcv = NULL; @@ -7508,9 +7870,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (cv) { /* must reuse cv if autoloaded */ /* transfer PL_compcv to cv */ if (block -#ifdef PERL_MAD - && block->op_type != OP_NULL -#endif ) { cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; PADLIST *const temp_av = CvPADLIST(cv); @@ -7519,12 +7878,26 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); OP * const cvstart = CvSTART(cv); - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvPADLIST(cv) = CvPADLIST(PL_compcv); @@ -7556,16 +7929,35 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } else { cv = PL_compcv; - if (name) { + if (name && isGV(gv)) { GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ gv_method_changed(gv); } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + } } - if (!CvGV(cv)) { - CvGV_set(cv, gv); + if (!CvHASGV(cv)) { + if (isGV(gv)) CvGV_set(cv, gv); + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } @@ -7575,7 +7967,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } - install_block: if (!block) goto attrs; @@ -7588,11 +7979,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { OP* const newblock = newSTATEOP(0, NULL, 0); -#ifdef PERL_MAD - op_getmad(block,newblock,'B'); -#else op_free(block); -#endif block = newblock; } CvROOT(cv) = CvLVALUE(cv) @@ -7612,15 +7999,24 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); 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); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); if (!name) SvREFCNT_inc_simple_void_NN(cv); @@ -7628,7 +8024,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); + SV * const tmpstr = cv_name(cv,NULL); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -7636,7 +8032,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); @@ -7652,8 +8047,15 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } } - if (name && ! (PL_parser && PL_parser->error_count)) - process_special_blocks(floor, name, gv, cv); + if (name) { + if (PL_parser && PL_parser->error_count) + clear_special_blocks(name, gv, cv); + else +#ifdef PERL_DEBUG_READONLY_OPS + special = +#endif + process_special_blocks(floor, name, gv, cv); + } } done: @@ -7662,12 +8064,37 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS /* Watch out for BEGIN blocks */ - if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); + if (!special) Slab_to_ro(slab); #endif return cv; } STATIC void +S_clear_special_blocks(pTHX_ const char *const fullname, + GV *const gv, CV *const cv) { + const char *colon; + const char *name; + + PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS; + + colon = strrchr(fullname,':'); + name = colon ? colon + 1 : fullname; + + if ((*name == 'B' && strEQ(name, "BEGIN")) + || (*name == 'E' && strEQ(name, "END")) + || (*name == 'U' && strEQ(name, "UNITCHECK")) + || (*name == 'C' && strEQ(name, "CHECK")) + || (*name == 'I' && strEQ(name, "INIT"))) { + if (!isGV(gv)) { + (void)CvGV(cv); + assert(isGV(gv)); + } + GvCV_set(gv, NULL); + SvREFCNT_dec_NN(MUTABLE_SV(cv)); + } +} + +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) @@ -7680,8 +8107,11 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (*name == 'B') { if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; + dSP; + (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; + PUSHSTACKi(PERLSI_REQUIRE); SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); SAVEVPTR(PL_curcop); @@ -7691,24 +8121,26 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GvCV_set(gv,0); /* cv has been hijacked */ call_list(oldscope, PL_beginav); + POPSTACK; LEAVE; + return TRUE; } else - return; + return FALSE; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) @@ -7718,7 +8150,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) @@ -7728,11 +8160,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else - return; + return FALSE; DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ + return TRUE; } } @@ -7773,7 +8207,6 @@ CV * Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags, SV *sv) { - dVAR; CV* cv; const char *const file = CopFILE(PL_curcop); @@ -7838,6 +8271,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, U32 flags) { CV *cv; + bool interleave = FALSE; PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; @@ -7867,7 +8301,9 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, ), cv, const_svp); } - SvREFCNT_dec_NN(cv); + interleave = TRUE; + ENTER; + SAVEFREESV(cv); cv = NULL; } } @@ -7902,6 +8338,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, CvDYNFILE_on(cv); } sv_setpv(MUTABLE_SV(cv), proto); + if (interleave) LEAVE; return cv; } @@ -7946,18 +8383,10 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) ); } -#ifdef PERL_MAD -OP * -#else void -#endif Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dVAR; CV *cv; -#ifdef PERL_MAD - OP* pegop = newOP(OP_NULL, 0); -#endif GV *gv; @@ -8002,21 +8431,14 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(&CvSTART(cv)); cv_forget_slab(cv); finish: -#ifdef PERL_MAD - op_getmad(o,pegop,'n'); - op_getmad_weak(block, pegop, 'b'); -#else op_free(o); -#endif if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); -#ifdef PERL_MAD - return pegop; -#endif } OP * @@ -8054,11 +8476,13 @@ Perl_oopsAV(pTHX_ OP *o) switch (o->op_type) { case OP_PADSV: + case OP_PADHV: o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return ref(o, OP_RV2AV); case OP_RV2SV: + case OP_RV2HV: o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; ref(o, OP_RV2AV); @@ -8112,8 +8536,7 @@ Perl_newAVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Using an array as a reference is deprecated"); + Perl_croak(aTHX_ "Can't use an array as a reference"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -8139,8 +8562,7 @@ Perl_newHVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Using a hash as a reference is deprecated"); + Perl_croak(aTHX_ "Can't use a hash as a reference"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -8180,16 +8602,83 @@ Perl_ck_anoncode(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_ANONCODE; cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type); - if (!PL_madskills) - cSVOPo->op_sv = NULL; + cSVOPo->op_sv = NULL; return o; } +static void +S_io_hints(pTHX_ OP *o) +{ +#if O_BINARY != 0 || O_TEXT != 0 + HV * const table = + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; + if (table) { + SV **svp = hv_fetchs(table, "open_IN", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); + /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ +# if O_BINARY != 0 + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; +# endif +# if O_TEXT != 0 + if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; +# endif + } + + svp = hv_fetchs(table, "open_OUT", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); + /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ +# if O_BINARY != 0 + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; +# endif +# if O_TEXT != 0 + if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; +# endif + } + } +#else + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(o); +#endif +} + OP * -Perl_ck_bitop(pTHX_ OP *o) +Perl_ck_backtick(pTHX_ OP *o) { - dVAR; + GV *gv; + OP *newop = NULL; + OP *sibl; + PERL_ARGS_ASSERT_CK_BACKTICK; + /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ + if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first)) + && (gv = gv_override("readpipe",8))) + { + /* detach rest of siblings from o and its first child */ + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + newop = S_new_entersubop(aTHX_ gv, sibl); + } + else if (!(o->op_flags & OPf_KIDS)) + newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); + if (newop) { + op_free(o); + return newop; + } + S_io_hints(aTHX_ o); + return o; +} +OP * +Perl_ck_bitop(pTHX_ OP *o) +{ PERL_ARGS_ASSERT_CK_BITOP; o->op_private = (U8)(PL_hints & HINT_INTEGER); @@ -8199,7 +8688,7 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_XOR)) { const OP * const left = cBINOPo->op_first; - const OP * const right = left->op_sibling; + const OP * const right = OP_SIBLING(left); if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -8217,6 +8706,7 @@ PERL_STATIC_INLINE bool is_dollar_bracket(pTHX_ const OP * const o) { const OP *kid; + PERL_UNUSED_CONTEXT; return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS && (kid = cUNOPx(o)->op_first) && kid->op_type == OP_GV @@ -8229,14 +8719,16 @@ 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->op_sibling && kid->op_sibling->op_type == OP_CONST + if (kid && + ( + ( is_dollar_bracket(aTHX_ kid) + && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST ) - || ( kid->op_type == OP_CONST - && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) - )) + || ( kid->op_type == OP_CONST + && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) + ) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); } @@ -8267,23 +8759,22 @@ Perl_ck_spair(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; + OP* kidkid; const OPCODE type = o->op_type; o = modkids(ck_fun(o), type); - kid = cUNOPo->op_first; - newop = kUNOP->op_first->op_sibling; + kid = cUNOPo->op_first; + kidkid = kUNOP->op_first; + newop = OP_SIBLING(kidkid); if (newop) { const OPCODE type = newop->op_type; - if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || + if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) || type == OP_PADAV || type == OP_PADHV || type == OP_RV2AV || type == OP_RV2HV) return o; } -#ifdef PERL_MAD - op_getmad(kUNOP->op_first,newop,'K'); -#else - op_free(kUNOP->op_first); -#endif - kUNOP->op_first = newop; + /* excise first sibling */ + op_sibling_splice(kid, NULL, 1, NULL); + op_free(kidkid); } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, * and OP_CHOMP into OP_SCHOMP */ @@ -8303,18 +8794,24 @@ Perl_ck_delete(pTHX_ OP *o) switch (kid->op_type) { case OP_ASLICE: o->op_flags |= OPf_SPECIAL; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_HSLICE: o->op_private |= OPpSLICE; break; case OP_AELEM: o->op_flags |= OPf_SPECIAL; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_HELEM: break; + case OP_KVASLICE: + Perl_croak(aTHX_ "delete argument is index/value array slice," + " use array slice"); + case OP_KVHSLICE: + Perl_croak(aTHX_ "delete argument is key/value hash slice, use" + " hash slice"); default: - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", - OP_DESC(o)); + Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " + "element or slice"); } if (kid->op_private & OPpLVAL_INTRO) o->op_private |= OPpLVAL_INTRO; @@ -8324,21 +8821,8 @@ Perl_ck_delete(pTHX_ OP *o) } OP * -Perl_ck_die(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_DIE; - -#ifdef VMS - if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; -#endif - return ck_fun(o); -} - -OP * Perl_ck_eof(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { @@ -8346,11 +8830,7 @@ Perl_ck_eof(pTHX_ OP *o) if (cLISTOPo->op_first->op_type == OP_STUB) { OP * const newop = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif o = newop; } o = ck_fun(o); @@ -8375,19 +8855,13 @@ Perl_ck_eval(pTHX_ OP *o) if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; -#ifdef PERL_MAD - OP* const oldo = o; -#endif - cUNOPo->op_first = 0; -#ifndef PERL_MAD + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); op_free(o); -#endif - NewOp(1101, enter, 1, LOGOP); - enter->op_type = OP_ENTERTRY; + enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL); enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; - enter->op_private = 0; /* establish postfix order */ enter->op_next = (OP*)enter; @@ -8396,7 +8870,6 @@ Perl_ck_eval(pTHX_ OP *o) o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; enter->op_other = o; - op_getmad(oldo,o,'O'); return o; } else { @@ -8406,13 +8879,12 @@ 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, priv <<8, newDEFSVOP()); - op_getmad(oldo,o,'O'); + /* the newUNOP will recursively call ck_eval(), which will handle + * all the stuff at the end of this function, like adding + * OP_HINTSEVAL + */ + return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; @@ -8421,7 +8893,9 @@ Perl_ck_eval(pTHX_ OP *o) /* 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; + /* append hhop to only child */ + op_sibling_splice(o, cUNOPo->op_first, 0, hhop); + o->op_private |= OPpEVAL_HAS_HH; } if (!(o->op_private & OPpEVAL_BYTES) @@ -8431,23 +8905,6 @@ Perl_ck_eval(pTHX_ OP *o) } OP * -Perl_ck_exit(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_EXIT; - -#ifdef VMS - HV * const table = GvHV(PL_hintgv); - if (table) { - SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE); - if (svp && *svp && SvTRUE(*svp)) - o->op_private |= OPpEXIT_VMSISH; - } - if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; -#endif - return ck_fun(o); -} - -OP * Perl_ck_exec(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_EXEC; @@ -8455,7 +8912,7 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; o = ck_fun(o); - kid = cUNOPo->op_first->op_sibling; + kid = OP_SIBLING(cUNOPo->op_first); if (kid->op_type == OP_RV2GV) op_null(kid); } @@ -8467,8 +8924,6 @@ Perl_ck_exec(pTHX_ OP *o) OP * Perl_ck_exists(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EXISTS; o = ck_fun(o); @@ -8478,15 +8933,15 @@ Perl_ck_exists(pTHX_ OP *o) (void) ref(kid, o->op_type); if (kid->op_type != OP_RV2CV && !(PL_parser && PL_parser->error_count)) - Perl_croak(aTHX_ "%s argument is not a subroutine name", - OP_DESC(o)); + Perl_croak(aTHX_ + "exists argument is not a subroutine name"); o->op_private |= OPpEXISTS_SUB; } else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", - OP_DESC(o)); + Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " + "element or a subroutine"); op_null(kid); } return o; @@ -8501,8 +8956,6 @@ Perl_ck_rvconst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RVCONST; o->op_private |= (PL_hints & HINT_STRICT_REFS); - if (o->op_type == OP_RV2CV) - o->op_private &= ~1; if (kid->op_type == OP_CONST) { int iscv; @@ -8510,31 +8963,7 @@ Perl_ck_rvconst(pTHX_ OP *o) SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ - if (SvROK(kidsv) && SvREADONLY(kidsv)) { - SV * const rsv = SvRV(kidsv); - const svtype type = SvTYPE(rsv); - const char *badtype = NULL; - - switch (o->op_type) { - case OP_RV2SV: - if (type > SVt_PVMG) - badtype = "a SCALAR"; - break; - case OP_RV2AV: - if (type != SVt_PVAV) - badtype = "an ARRAY"; - break; - case OP_RV2HV: - if (type != SVt_PVHV) - badtype = "a HASH"; - break; - case OP_RV2CV: - if (type != SVt_PVCV) - badtype = "a CODE"; - break; - } - if (badtype) - Perl_croak(aTHX_ "Constant is not %s reference", badtype); + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { return o; } if (SvTYPE(kidsv) == SVt_PVAV) return o; @@ -8567,10 +8996,12 @@ Perl_ck_rvconst(pTHX_ OP *o) * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - iscv = (o->op_type == OP_RV2CV) * 2; - do { - gv = gv_fetchsv(kidsv, - iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV @@ -8580,16 +9011,21 @@ Perl_ck_rvconst(pTHX_ OP *o) : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); - } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ assert (sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); @@ -8622,11 +9058,7 @@ Perl_ck_ftst(pTHX_ OP *o) && !kid->op_folded) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif return newop; } if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) @@ -8643,16 +9075,11 @@ Perl_ck_ftst(pTHX_ OP *o) } } else { -#ifdef PERL_MAD - OP* const oldo = o; -#else op_free(o); -#endif if (type == OP_FTTTY) o = newGVOP(type, OPf_REF, PL_stdingv); else o = newUNOP(type, 0, newDEFSVOP()); - op_getmad(oldo,o,'O'); } return o; } @@ -8660,7 +9087,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dVAR; const int type = o->op_type; I32 oa = PL_opargs[type] >> OASHIFT; @@ -8674,17 +9100,16 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - OP **tokid = &cLISTOPo->op_first; + OP *prev_kid = NULL; OP *kid = cLISTOPo->op_first; - OP *sibl; I32 numargs = 0; bool seen_optional = FALSE; if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } if (kid && kid->op_type == OP_COREARGS) { bool optional = FALSE; @@ -8699,20 +9124,16 @@ Perl_ck_fun(pTHX_ OP *o) while (oa) { if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { - if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) - *tokid = kid = newDEFSVOP(); + if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { + kid = newDEFSVOP(); + /* append kid to chain */ + op_sibling_splice(o, prev_kid, 0, kid); + } seen_optional = TRUE; } if (!kid) break; numargs++; - sibl = kid->op_sibling; -#ifdef PERL_MAD - if (!sibl && kid->op_type == OP_STUB) { - numargs--; - break; - } -#endif switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ @@ -8721,7 +9142,7 @@ Perl_ck_fun(pTHX_ OP *o) { return too_many_arguments_pv(o,PL_op_desc[type], 0); } - scalar(kid); + if (type != OP_DELETE) scalar(kid); break; case OA_LIST: if (oa < 16) { @@ -8733,29 +9154,12 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !kid->op_sibling) + && !OP_HAS_SIBLING(kid)) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else - op_free(kid); -#endif - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type == OP_CONST + if (kid->op_type == OP_CONST && ( !SvROK(cSVOPx_sv(kid)) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) @@ -8763,38 +9167,27 @@ Perl_ck_fun(pTHX_ OP *o) /* Defer checks to run-time if we have a scalar arg */ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) op_lvalue(kid, type); - else scalar(kid); + else { + scalar(kid); + /* diag_listed_as: push on reference is experimental */ + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__AUTODEREF), + "%s on reference is experimental", + PL_op_desc[type]); + } break; case OA_HVREF: - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else - op_free(kid); -#endif - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) + if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); op_lvalue(kid, type); break; case OA_CVREF: { - OP * const newop = newUNOP(OP_NULL, 0, kid); - kid->op_sibling = 0; + /* replace kid with newop in chain */ + OP * const newop = + S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); newop->op_next = newop; kid = newop; - kid->op_sibling = sibl; - *tokid = kid; } break; case OA_FILEREF: @@ -8804,14 +9197,9 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); - if (!(o->op_private & 1) && /* if not unop */ - kid == cLISTOPo->op_last) - cLISTOPo->op_last = newop; -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else + /* replace kid with newop in chain */ + op_sibling_splice(o, prev_kid, 1, newop); op_free(kid); -#endif kid = newop; } else if (kid->op_type == OP_READLINE) { @@ -8911,13 +9299,12 @@ Perl_ck_fun(pTHX_ OP *o) if ( name_utf8 ) SvUTF8_on(namesv); } } - kid->op_sibling = 0; - kid = newUNOP(OP_RV2GV, flags, scalar(kid)); - kid->op_targ = targ; - kid->op_private |= priv; + scalar(kid); + kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, + OP_RV2GV, flags); + kid->op_targ = targ; + kid->op_private |= priv; } - kid->op_sibling = sibl; - *tokid = kid; } scalar(kid); break; @@ -8930,31 +9317,20 @@ Perl_ck_fun(pTHX_ OP *o) break; } oa >>= 4; - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } -#ifdef PERL_MAD - if (kid && kid->op_type != OP_STUB) - return too_many_arguments_pv(o,OP_DESC(o), 0); - o->op_private |= numargs; -#else - /* FIXME - should the numargs move as for the PERL_MAD case? */ + /* FIXME - should the numargs or-ing move after the too many + * arguments check? */ o->op_private |= numargs; if (kid) return too_many_arguments_pv(o,OP_DESC(o), 0); -#endif listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { -#ifdef PERL_MAD - OP *newop = newUNOP(type, 0, newDEFSVOP()); - op_getmad(o,newop,'O'); - return newop; -#else /* Ordering of these two is important to keep f_map.t passing. */ op_free(o); return newUNOP(type, 0, newDEFSVOP()); -#endif } if (oa) { @@ -8969,26 +9345,16 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { - dVAR; GV *gv; - const bool core = o->op_flags & OPf_SPECIAL; PERL_ARGS_ASSERT_CK_GLOB; o = ck_fun(o); - if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first)) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ - if (core) gv = NULL; - else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) - && GvCVu(gv) && GvIMPORTED_CV(gv))) + if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) { - GV * const * const gvp = - (GV **)hv_fetchs(PL_globalstash, "glob", FALSE); - gv = gvp ? *gvp : NULL; - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { /* convert * glob * \ null - const(wildcard) @@ -9003,11 +9369,7 @@ Perl_ck_glob(pTHX_ OP *o) */ o->op_flags |= OPf_SPECIAL; o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - o = newLISTOP(OP_LIST, 0, o, NULL); - o = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, o, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, gv))))); + o = S_new_entersubop(aTHX_ gv, o); o = newUNOP(OP_NULL, 0, o); o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ return o; @@ -9045,12 +9407,12 @@ Perl_ck_grep(pTHX_ OP *o) /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { - kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; + kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first; if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) return no_fh_allowed(o); o->op_flags &= ~OPf_STACKED; } - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) list(kid); else @@ -9058,17 +9420,13 @@ Perl_ck_grep(pTHX_ OP *o) o = ck_fun(o); if (PL_parser && PL_parser->error_count) return o; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; - NewOp(1101, gwop, 1, LOGOP); - gwop->op_type = type; + gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); gwop->op_ppaddr = PL_ppaddr[type]; - gwop->op_first = o; - gwop->op_flags |= OPf_KIDS; - gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { @@ -9080,8 +9438,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_targ = o->op_targ = offset; } - kid = cLISTOPo->op_first->op_sibling; - for (kid = kid->op_sibling; kid; kid = kid->op_sibling) + kid = OP_SIBLING(cLISTOPo->op_first); + for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; @@ -9093,9 +9451,9 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid) - kid = kid->op_sibling; /* get past "big" */ + kid = OP_SIBLING(kid); /* get past "big" */ if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; SV *sv = kSVOP->op_sv; @@ -9134,18 +9492,13 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ switch (cUNOPo->op_first->op_type) { case OP_RV2AV: case OP_PADAV: - case OP_AASSIGN: /* Is this a good idea? */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "defined(@array) is deprecated"); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_croak(aTHX_ "Can't use 'defined(@array)'" + " (Maybe you should just omit the defined()?)"); break; case OP_RV2HV: case OP_PADHV: - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "defined(%%hash) is deprecated"); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" + " (Maybe you should just omit the defined()?)"); break; default: /* no warning */ @@ -9167,11 +9520,7 @@ Perl_ck_readline(pTHX_ OP *o) else { OP * const newop = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif return newop; } return o; @@ -9196,21 +9545,22 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; if (!kid) { - o = force_list(o); + o = force_list(o, 1); kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = kid->op_sibling; - else if (kid && !kid->op_sibling) { /* print HANDLE; */ + kid = OP_SIBLING(kid); + else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE && !kid->op_folded) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ - kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOPo->op_first->op_sibling = kid; - cLISTOPo->op_last = kid; - kid = kid->op_sibling; + scalar(kid); + /* replace old const op with new OP_RV2GV parent */ + kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, + OP_RV2GV, OPf_REF); + kid = OP_SIBLING(kid); } } @@ -9228,12 +9578,19 @@ Perl_ck_smartmatch(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SMARTMATCH; if (0 == (o->op_flags & OPf_SPECIAL)) { OP *first = cBINOPo->op_first; - OP *second = first->op_sibling; + OP *second = OP_SIBLING(first); /* Implicitly take a reference to an array or hash */ - first->op_sibling = NULL; - first = cBINOPo->op_first = ref_array_or_hash(first); - second = first->op_sibling = ref_array_or_hash(second); + + /* remove the original two siblings, then add back the + * (possibly different) first and second sibs. + */ + op_sibling_splice(o, NULL, 1, NULL); + op_sibling_splice(o, NULL, 1, NULL); + first = ref_array_or_hash(first); + second = ref_array_or_hash(second); + op_sibling_splice(o, NULL, 0, second); + op_sibling_splice(o, NULL, 0, first); /* Implicitly take a reference to a regular expression */ if (first->op_type == OP_MATCH) { @@ -9263,11 +9620,9 @@ Perl_ck_sassign(pTHX_ OP *o) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY) - /* Keep the full thing for madskills */ - && !PL_madskills ) { - OP * const kkid = kid->op_sibling; + OP * const kkid = OP_SIBLING(kid); /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV @@ -9275,26 +9630,28 @@ Perl_ck_sassign(pTHX_ OP *o) { kid->op_targ = kkid->op_targ; kkid->op_targ = 0; - /* Now we do not need PADSV and SASSIGN. */ - kid->op_sibling = o->op_sibling; /* NULL */ - cLISTOPo->op_first = NULL; + /* Now we do not need PADSV and SASSIGN. + * first replace the PADSV with OP_SIBLING(o), then + * detach kid and OP_SIBLING(o) from o */ + op_sibling_splice(o, kid, 1, OP_SIBLING(o)); + op_sibling_splice(o, NULL, -1, NULL); op_free(o); op_free(kkid); kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } } - if (kid->op_sibling) { - OP *kkid = kid->op_sibling; + if (OP_HAS_SIBLING(kid)) { + OP *kkid = OP_SIBLING(kid); /* For state variable assignment, kkid is a list op whose op_last is a padsv. */ if ((kkid->op_type == OP_PADSV || - (kkid->op_type == OP_LIST && + (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV ) ) && (kkid->op_private & OPpLVAL_INTRO) - && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { + && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) { const PADOFFSET target = kkid->op_targ; OP *const other = newOP(OP_PADSV, kkid->op_flags @@ -9311,10 +9668,14 @@ Perl_ck_sassign(pTHX_ OP *o) other->op_targ = target; /* Because we change the type of the op here, we will skip the - assignment binop->op_last = binop->op_first->op_sibling; at the + assignment binop->op_last = OP_SIBLING(binop->op_first); at the end of Perl_newBINOP(). So need to do it here. */ - cBINOPo->op_last = cBINOPo->op_first->op_sibling; - + cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first); + cBINOPo->op_first->op_lastsib = 0; + cBINOPo->op_last ->op_lastsib = 1; +#ifdef PERL_OP_PARENT + cBINOPo->op_last->op_sibling = o; +#endif return nullop; } } @@ -9324,8 +9685,6 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { @@ -9359,11 +9718,7 @@ Perl_ck_method(pTHX_ OP *o) kSVOP->op_sv = NULL; } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); -#ifdef PERL_MAD - op_getmad(o,cmop,'O'); -#else op_free(o); -#endif return cmop; } } @@ -9381,46 +9736,9 @@ Perl_ck_null(pTHX_ OP *o) OP * Perl_ck_open(pTHX_ OP *o) { - dVAR; - HV * const table = GvHV(PL_hintgv); - PERL_ARGS_ASSERT_CK_OPEN; - if (table) { - SV **svp = hv_fetchs(table, "open_IN", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); - if (mode & O_BINARY) - o->op_private |= OPpOPEN_IN_RAW; - else if (mode & O_TEXT) - o->op_private |= OPpOPEN_IN_CRLF; - } - - svp = hv_fetchs(table, "open_OUT", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); - if (mode & O_BINARY) - o->op_private |= OPpOPEN_OUT_RAW; - else if (mode & O_TEXT) - o->op_private |= OPpOPEN_OUT_CRLF; - } - } - if (o->op_type == OP_BACKTICK) { - if (!(o->op_flags & OPf_KIDS)) { - OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else - op_free(o); -#endif - return newop; - } - return o; - } + S_io_hints(aTHX_ o); { /* In case of three-arg dup open remove strictness * from the last arg if it is a bareword. */ @@ -9432,13 +9750,13 @@ Perl_ck_open(pTHX_ OP *o) if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && - (oa = first->op_sibling) && /* The fh. */ - (oa = oa->op_sibling) && /* The mode. */ + (oa = OP_SIBLING(first)) && /* The fh. */ + (oa = OP_SIBLING(oa)) && /* The mode. */ (oa->op_type == OP_CONST) && SvPOK(((SVOP*)oa)->op_sv) && (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ - (last == oa->op_sibling)) /* The bareword. */ + (last == OP_SIBLING(oa))) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); @@ -9450,8 +9768,11 @@ Perl_ck_repeat(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_REPEAT; if (cBINOPo->op_first->op_flags & OPf_PARENS) { + OP* kids; o->op_private |= OPpREPEAT_DOLIST; - cBINOPo->op_first = force_list(cBINOPo->op_first); + kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */ + kids = force_list(kids, 1); /* promote them to a list */ + op_sibling_splice(o, NULL, 0, kids); /* and add back */ } else scalar(o); @@ -9461,19 +9782,21 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { - dVAR; - GV* gv = NULL; + GV* gv; PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - SV * const sv = kid->op_sv; - U32 was_readonly = SvREADONLY(sv); - char *s; - STRLEN len; + HEK *hek; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + dVAR; const char *end; if (was_readonly) { @@ -9493,37 +9816,49 @@ Perl_ck_require(pTHX_ OP *o) } SvEND_set(sv, end); sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { + dVAR; + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } } } - if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */ + if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ /* handle override, if any */ - gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV); - if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE); - gv = gvp ? *gvp : NULL; - } - } - - if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { + && (gv = gv_override("require", 7))) { OP *kid, *newop; if (o->op_flags & OPf_KIDS) { kid = cUNOPo->op_first; - cUNOPo->op_first = NULL; + op_sibling_splice(o, NULL, -1, NULL); } else { kid = newDEFSVOP(); } -#ifndef PERL_MAD op_free(o); -#endif - newop = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, kid, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv))))); - op_getmad(o,newop,'O'); + newop = S_new_entersubop(aTHX_ gv, kid); return newop; } @@ -9533,14 +9868,13 @@ Perl_ck_require(pTHX_ OP *o) OP * Perl_ck_return(pTHX_ OP *o) { - dVAR; OP *kid; PERL_ARGS_ASSERT_CK_RETURN; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (CvLVALUE(PL_compcv)) { - for (; kid; kid = kid->op_sibling) + for (; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_LEAVESUBLV); } @@ -9556,8 +9890,8 @@ Perl_ck_select(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SELECT; if (o->op_flags & OPf_KIDS) { - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (kid && kid->op_sibling) { + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && OP_HAS_SIBLING(kid)) { o->op_type = OP_SSELECT; o->op_ppaddr = PL_ppaddr[OP_SSELECT]; o = ck_fun(o); @@ -9565,7 +9899,7 @@ Perl_ck_select(pTHX_ OP *o) } } o = ck_fun(o); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; return o; @@ -9574,7 +9908,6 @@ Perl_ck_select(pTHX_ OP *o) OP * Perl_ck_shift(pTHX_ OP *o) { - dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_SHIFT; @@ -9588,17 +9921,8 @@ Perl_ck_shift(pTHX_ OP *o) } argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); -#ifdef PERL_MAD - { - OP * const oldo = o; - o = newUNOP(type, 0, scalar(argop)); - op_getmad(oldo,o,'O'); - return o; - } -#else op_free(o); return newUNOP(type, 0, scalar(argop)); -#endif } return scalar(ck_fun(o)); } @@ -9606,7 +9930,6 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { - dVAR; OP *firstkid; OP *kid; HV * const hinthv = @@ -9628,10 +9951,13 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); - firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ + /* if the first arg is a code block, process it and mark sort as + * OPf_SPECIAL */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { LINKLIST(kid); if (kid->op_type == OP_LEAVE) @@ -9644,11 +9970,38 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = kid; o->op_flags |= OPf_SPECIAL; } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv)); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; + cUNOPx(firstkid)->op_first = padop; + op_free(kid); + } + } + } - firstkid = firstkid->op_sibling; + firstkid = OP_SIBLING(firstkid); } - for (kid = firstkid; kid; kid = kid->op_sibling) { + for (kid = firstkid; kid; kid = OP_SIBLING(kid)) { /* provide list context for arguments */ list(kid); if (stacked) @@ -9658,11 +10011,20 @@ Perl_ck_sort(pTHX_ OP *o) return o; } +/* for sort { X } ..., where X is one of + * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a + * elide the second child of the sort (the one containing X), + * and set these flags as appropriate + OPpSORT_NUMERIC; + OPpSORT_INTEGER; + OPpSORT_DESCEND; + * Also, check and warn on lexical $a, $b. + */ + STATIC void S_simplify_sort(pTHX_ OP *o) { - dVAR; - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ OP *k; int descending; GV *gv; @@ -9671,8 +10033,6 @@ S_simplify_sort(pTHX_ OP *o) PERL_ARGS_ASSERT_SIMPLIFY_SORT; - GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV)); - GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV)); kid = kUNOP->op_first; /* get past null */ if (!(have_scopeop = kid->op_type == OP_SCOPE) && kid->op_type != OP_LEAVE) @@ -9706,7 +10066,7 @@ S_simplify_sort(pTHX_ OP *o) kid = kBINOP->op_first; do { if (kid->op_type == OP_PADSV) { - SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ]; + SV * const name = PAD_COMPNAME_SV(kid->op_targ); if (SvCUR(name) == 2 && *SvPVX(name) == '$' && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b')) /* diag_listed_as: "my %s" used in sort comparison */ @@ -9715,7 +10075,7 @@ S_simplify_sort(pTHX_ OP *o) SvPAD_STATE(name) ? "state" : "my", SvPVX(name)); } - } while ((kid = kid->op_sibling)); + } while ((kid = OP_SIBLING(kid))); return; } kid = kBINOP->op_first; /* get past cmp */ @@ -9754,13 +10114,10 @@ S_simplify_sort(pTHX_ OP *o) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; - kid = cLISTOPo->op_first->op_sibling; - cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ -#ifdef PERL_MAD - op_getmad(kid,o,'S'); /* then delete it */ -#else - op_free(kid); /* then delete it */ -#endif + kid = OP_SIBLING(cLISTOPo->op_first); + /* cut out and delete old block (second sibling) */ + op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); + op_free(kid); } OP * @@ -9777,23 +10134,18 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); - kid = kid->op_sibling; - op_free(cLISTOPo->op_first); - if (kid) - cLISTOPo->op_first = kid; - else { - cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); - cLISTOPo->op_last = kid; /* There was only one element previously */ - } + /* delete leading NULL node, then add a CONST if no other nodes */ + op_sibling_splice(o, NULL, 1, + OP_HAS_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) { - OP * const sibl = kid->op_sibling; - kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */ - if (cLISTOPo->op_first == cLISTOPo->op_last) - cLISTOPo->op_last = kid; - cLISTOPo->op_first = kid; - kid->op_sibling = sibl; + /* remove kid, and replace with new optree */ + op_sibling_splice(o, NULL, 1, NULL); + /* OPf_SPECIAL is used to trigger split " " behavior */ + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); + op_sibling_splice(o, NULL, 0, kid); } kid->op_type = OP_PUSHRE; @@ -9804,23 +10156,24 @@ Perl_ck_split(pTHX_ OP *o) "Use of /g modifier is meaningless in split"); } - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) op_append_elem(OP_SPLIT, o, newDEFSVOP()); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); + assert(kid); scalar(kid); - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) { op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); o->op_private |= OPpSPLIT_IMPLIM; } - assert(kid->op_sibling); + assert(OP_HAS_SIBLING(kid)); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); scalar(kid); - if (kid->op_sibling) + if (OP_HAS_SIBLING(kid)) return too_many_arguments_pv(o,OP_DESC(o), 0); return o; @@ -9829,7 +10182,7 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - const OP * const kid = cLISTOPo->op_first->op_sibling; + const OP * const kid = OP_SIBLING(cLISTOPo->op_first); PERL_ARGS_ASSERT_CK_JOIN; @@ -9916,7 +10269,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) CV *cv; GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; - if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV)) + if (flags & ~RV2CVOPCV_FLAG_MASK) Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) return NULL; @@ -9928,6 +10281,16 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) switch (rvop->op_type) { case OP_GV: { gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } cv = GvCVu(gv); if (!cv) { if (flags & RV2CVOPCV_MARK_EARLY) @@ -9948,12 +10311,13 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } break; default: { return NULL; - } break; + } NOT_REACHED; /* NOTREACHED */ } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if (!CvANON(cv) || !gv) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -9980,13 +10344,11 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) OP *aop; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { - if (!(PL_madskills && aop->op_type == OP_STUB)) { - list(aop); - op_lvalue(aop, OP_ENTERSUB); - } + for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) { + list(aop); + op_lvalue(aop, OP_ENTERSUB); } return entersubop; } @@ -10024,7 +10386,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { STRLEN proto_len; const char *proto, *proto_end; - OP *aop, *prev, *cvop; + OP *aop, *prev, *cvop, *parent; int optional = 0; I32 arg = 0; I32 contextclass = 0; @@ -10038,25 +10400,25 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) else proto = SvPV(protosv, proto_len); proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; + parent = entersubop; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } prev = aop; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; while (aop != cvop) { - OP* o3; - if (PL_madskills && aop->op_type == OP_STUB) { - aop = aop->op_sibling; - continue; - } - if (PL_madskills && aop->op_type == OP_NULL) - o3 = ((UNOP*)aop)->op_first; - else - o3 = aop; + OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -10067,6 +10429,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) /* _ must be at the end */ if (proto[1] && !strchr(";@%", proto[1])) goto oops; + /* FALLTHROUGH */ case '$': proto++; arg++; @@ -10093,36 +10456,6 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; /* autoconvert GLOB -> GLOBref */ else if (o3->op_type == OP_CONST) o3->op_private &= ~OPpCONST_STRICT; - else if (o3->op_type == OP_ENTERSUB) { - /* accidental subroutine, revert to bareword */ - OP *gvop = ((UNOP*)o3)->op_first; - if (gvop && gvop->op_type == OP_NULL) { - gvop = ((UNOP*)gvop)->op_first; - if (gvop) { - for (; gvop->op_sibling; gvop = gvop->op_sibling) - ; - if (gvop && - (gvop->op_private & OPpENTERSUB_NOPAREN) && - (gvop = ((UNOP*)gvop)->op_first) && - gvop->op_type == OP_GV) - { - GV * const gv = cGVOPx_gv(gvop); - OP * const sibling = aop->op_sibling; - SV * const n = newSVpvs(""); -#ifdef PERL_MAD - OP * const oldaop = aop; -#else - op_free(aop); -#endif - gv_fullname4(n, gv, "", FALSE); - aop = newSVOP(OP_CONST, 0, n); - op_getmad(oldaop,aop,'O'); - prev->op_sibling = aop; - aop->op_sibling = sibling; - } - } - } - } scalar(aop); break; case '+': @@ -10139,7 +10472,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) break; case '[': case ']': goto oops; - break; + case '\\': proto++; arg++; @@ -10154,7 +10487,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) else goto oops; goto again; - break; + case ']': if (contextclass) { const char *p = proto; @@ -10218,14 +10551,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) bad_type_gv(arg, "hash", namegv, 0, o3); break; wrapref: - { - OP* const kid = aop; - OP* const sib = kid->op_sibling; - kid->op_sibling = 0; - aop = newUNOP(OP_REFGEN, 0, kid); - aop->op_sibling = sib; - prev->op_sibling = aop; - } + aop = S_op_sibling_newUNOP(aTHX_ parent, prev, + OP_REFGEN, 0); if (contextclass && e) { proto = e + 1; contextclass = 0; @@ -10241,26 +10568,27 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(protosv)); } } op_lvalue(aop, OP_ENTERSUB); prev = aop; - aop = aop->op_sibling; + aop = OP_SIBLING(aop); } if (aop == cvop && *proto == '_') { /* generate an access to $_ */ - aop = newDEFSVOP(); - aop->op_sibling = prev->op_sibling; - prev->op_sibling = aop; /* instead of cvop */ + op_sibling_splice(parent, prev, 0, newDEFSVOP()); } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10312,13 +10640,10 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!opnum) { OP *cvop; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - 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; - } + aop = OP_SIBLING(aop); + for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; if (aop != cvop) (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); @@ -10339,32 +10664,41 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) ) ); } - assert(0); + NOT_REACHED; } else { - OP *prev, *cvop; - U32 flags; -#ifdef PERL_MAD - bool seenarg = FALSE; -#endif - if (!aop->op_sibling) + OP *prev, *cvop, *first, *parent; + U32 flags = 0; + + parent = entersubop; + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } - prev = aop; - aop = aop->op_sibling; - prev->op_sibling = NULL; + first = prev = aop; + aop = OP_SIBLING(aop); + /* find last sibling */ for (cvop = aop; - cvop->op_sibling; - prev=cvop, cvop = cvop->op_sibling) -#ifdef PERL_MAD - if (PL_madskills && cvop->op_sibling - && cvop->op_type != OP_STUB) seenarg = TRUE -#endif + OP_HAS_SIBLING(cvop); + prev = cvop, cvop = OP_SIBLING(cvop)) ; - prev->op_sibling = NULL; - flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); + if (!(cvop->op_private & OPpENTERSUB_NOPAREN) + /* Usually, OPf_SPECIAL on a UNOP means that its arg had no + * parens, but these have their own meaning for that flag: */ + && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH + && opnum != OP_DELETE && opnum != OP_EXISTS) + flags |= OPf_SPECIAL; + /* excise cvop from end of sibling chain */ + op_sibling_splice(parent, prev, 1, NULL); op_free(cvop); if (aop == cvop) aop = NULL; + + /* detach remaining siblings from the first sibling, then + * dispose of original optree */ + + if (aop) + op_sibling_splice(parent, first, -1, NULL); op_free(entersubop); if (opnum == OP_ENTEREVAL @@ -10378,9 +10712,6 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags); case OA_BASEOP: if (aop) { -#ifdef PERL_MAD - if (!PL_madskills || seenarg) -#endif (void)too_many_arguments_pv(aop, GvNAME(namegv), 0); op_free(aop); } @@ -10425,23 +10756,33 @@ by L. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree for a @@ -10449,21 +10790,34 @@ subroutine call, not marked with C<&>, where the callee can be identified at compile time as I. The C-level function pointer is supplied in I, and an SV argument -for it is supplied in I. The function is intended to be called -in this manner: +for it is supplied in I. The function should be defined like this: + + STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj) + +It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, -which may be replaced by the check function, and I is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I supplies +the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L. You can force perl to pass a GV by including +C in the I. + The current setting for a particular CV can be retrieved by L. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L, which passes it the +C flag for backward-compatibility. + =cut */ @@ -10471,6 +10825,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10478,6 +10840,7 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) MAGIC *callmg; sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); + assert(callmg); if (callmg->mg_flags & MGf_REFCOUNTED) { SvREFCNT_dec(callmg->mg_obj); callmg->mg_flags &= ~MGf_REFCOUNTED; @@ -10488,7 +10851,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10502,12 +10866,12 @@ Perl_ck_subr(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SUBR; aop = cUNOPx(o)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10521,7 +10885,7 @@ Perl_ck_subr(pTHX_ OP *o) if (aop->op_type == OP_CONST) aop->op_private &= ~OPpCONST_STRICT; else if (aop->op_type == OP_LIST) { - OP * const sib = ((UNOP*)aop)->op_first->op_sibling; + OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); if (sib && sib->op_type == OP_CONST) sib->op_private &= ~OPpCONST_STRICT; } @@ -10532,21 +10896,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (!namegv) { + /* The original call checker API guarantees that a GV will be + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); } @@ -10569,6 +10936,9 @@ Perl_ck_svconst(pTHX_ OP *o) if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { SvIsCOW_on(sv); CowREFCNT(sv) = 0; +# ifdef PERL_DEBUG_READONLY_COW + sv_buf_to_ro(sv); +# endif } #endif SvREADONLY_on(sv); @@ -10584,7 +10954,7 @@ Perl_ck_trunc(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) - kid = (SVOP*)kid->op_sibling; + kid = (SVOP*)OP_SIBLING(kid); if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE) && !kid->op_folded) @@ -10606,7 +10976,7 @@ Perl_ck_substr(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid) kid->op_flags |= OPf_MOD; @@ -10621,7 +10991,7 @@ Perl_ck_tell(pTHX_ OP *o) 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_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid); if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; } return o; @@ -10663,7 +11033,13 @@ Perl_ck_each(pTHX_ OP *o) } } /* if treating as a reference, defer additional checks to runtime */ - return o->op_type == ref_type ? o : ck_fun(o); + if (o->op_type == ref_type) { + /* diag_listed_as: keys on reference is experimental */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF), + "%s is experimental", PL_op_desc[ref_type]); + return o; + } + return ck_fun(o); } OP * @@ -10683,19 +11059,9 @@ Perl_ck_length(pTHX_ OP *o) switch (kid->op_type) { case OP_PADHV: case OP_PADAV: - name = varname( - (GV *)PL_compcv, 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); - } + name = S_op_varname(aTHX_ kid); break; default: return o; @@ -10704,7 +11070,7 @@ Perl_ck_length(pTHX_ OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "length() used on %"SVf" (did you mean \"scalar(%s%"SVf ")\"?)", - name, hash ? "keys " : "", name + SVfARG(name), hash ? "keys " : "", SVfARG(name) ); else if (hash) /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ @@ -10737,39 +11103,39 @@ S_inplace_aassign(pTHX_ OP *o) { assert(cUNOPo->op_first->op_type == OP_NULL); modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; assert(modop_pushmark->op_type == OP_PUSHMARK); - modop = modop_pushmark->op_sibling; + modop = OP_SIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) return; /* no other operation except sort/reverse */ - if (modop->op_sibling) + if (OP_HAS_SIBLING(modop)) return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; + if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ assert(oright->op_type == OP_NULL); - oright = oright->op_sibling; + oright = OP_SIBLING(oright); } - assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); - oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; + assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL); + oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first; assert(oleft_pushmark->op_type == OP_PUSHMARK); - oleft = oleft_pushmark->op_sibling; + oleft = OP_SIBLING(oleft_pushmark); /* Check the lhs is an array */ if (!oleft || (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || oleft->op_sibling + || OP_HAS_SIBLING(oleft) || (oleft->op_private & OPpLVAL_INTRO) ) return; /* Only one thing on the rhs */ - if (oright->op_sibling) + if (OP_HAS_SIBLING(oright)) return; /* check the array is the same on both sides */ @@ -10803,18 +11169,48 @@ S_inplace_aassign(pTHX_ OP *o) { op_null(oleft); } + + +/* mechanism for deferring recursion in rpeep() */ + #define MAX_DEFERRED 4 #define DEFER(o) \ STMT_START { \ if (defer_ix == (MAX_DEFERRED-1)) { \ - CALL_RPEEP(defer_queue[defer_base]); \ + OP **defer = defer_queue[defer_base]; \ + CALL_RPEEP(*defer); \ + S_prune_chain_head(defer); \ defer_base = (defer_base + 1) % MAX_DEFERRED; \ defer_ix--; \ } \ - defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \ + defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ } STMT_END +#define IS_AND_OP(o) (o->op_type == OP_AND) +#define IS_OR_OP(o) (o->op_type == OP_OR) + + +STATIC void +S_null_listop_in_list_context(pTHX_ OP *o) +{ + OP *kid; + + PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT; + + /* This is an OP_LIST in list context. That means we + * can ditch the OP_LIST and the OP_PUSHMARK within. */ + + kid = cLISTOPo->op_first; + /* Find the end of the chain of OPs executed within the OP_LIST. */ + while (kid->op_next != o) + kid = kid->op_next; + + kid->op_next = o->op_next; /* patch list out of exec chain */ + op_null(cUNOPo->op_first); /* NULL the pushmark */ + op_null(o); /* NULL the list */ +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ @@ -10825,9 +11221,11 @@ Perl_rpeep(pTHX_ OP *o) dVAR; OP* oldop = NULL; OP* oldoldop = NULL; - OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ + 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; @@ -10838,8 +11236,12 @@ Perl_rpeep(pTHX_ OP *o) if (o && o->op_opt) o = NULL; if (!o) { - while (defer_ix >= 0) - CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]); + while (defer_ix >= 0) { + OP **defer = + defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; + CALL_RPEEP(*defer); + S_prune_chain_head(defer); + } break; } @@ -10847,6 +11249,44 @@ Perl_rpeep(pTHX_ OP *o) clear this again. */ o->op_opt = 1; PL_op = o; + + + /* The following will have the OP_LIST and OP_PUSHMARK + * patched out later IF the OP_LIST is in list context. + * So in that case, we can set the this OP's op_next + * to skip to after the OP_PUSHMARK: + * a THIS -> b + * d list -> e + * b pushmark -> c + * c whatever -> d + * e whatever + * will eventually become: + * a THIS -> c + * - ex-list -> - + * - ex-pushmark -> - + * c whatever -> e + * e whatever + */ + { + OP *sibling; + OP *other_pushmark; + if (OP_TYPE_IS(o->op_next, OP_PUSHMARK) + && (sibling = OP_SIBLING(o)) + && sibling->op_type == OP_LIST + /* This KIDS check is likely superfluous since OP_LIST + * would otherwise be an OP_STUB. */ + && sibling->op_flags & OPf_KIDS + && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST + && (other_pushmark = cLISTOPx(sibling)->op_first) + /* Pointer equality also effectively checks that it's a + * pushmark. */ + && other_pushmark == o->op_next) + { + o->op_next = other_pushmark->op_next; + null_listop_in_list_context(sibling); + } + } + switch (o->op_type) { case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ @@ -10854,6 +11294,120 @@ Perl_rpeep(pTHX_ OP *o) case OP_NEXTSTATE: PL_curcop = ((COP*)o); /* for warnings */ + /* Optimise a "return ..." at the end of a sub to just be "...". + * This saves 2 ops. Before: + * 1 <;> nextstate(main 1 -e:1) v ->2 + * 4 <@> return K ->5 + * 2 <0> pushmark s ->3 + * - <1> ex-rv2sv sK/1 ->4 + * 3 <#> gvsv[*cat] s ->4 + * + * After: + * - <@> return K ->- + * - <0> pushmark s ->2 + * - <1> ex-rv2sv sK/1 ->- + * 2 <$> gvsv(*cat) s ->3 + */ + { + OP *next = o->op_next; + OP *sibling = OP_SIBLING(o); + if ( OP_TYPE_IS(next, OP_PUSHMARK) + && OP_TYPE_IS(sibling, OP_RETURN) + && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) + && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) + && cUNOPx(sibling)->op_first == next + && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = OP_SIBLING(next); + while (top && top->op_next) { + if (top->op_next == sibling) { + top->op_next = sibling->op_next; + o->op_next = next->op_next; + break; + } + top = OP_SIBLING(top); + } + } + } + + /* Optimise 'my $x; my $y;' into 'my ($x, $y);' + * + * This latter form is then suitable for conversion into padrange + * later on. Convert: + * + * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 + * + * into: + * + * nextstate1 -> listop -> nextstate3 + * / \ + * pushmark -> padop1 -> padop2 + */ + if (o->op_next && ( + o->op_next->op_type == OP_PADSV + || o->op_next->op_type == OP_PADAV + || o->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE + && o->op_next->op_next->op_next && ( + o->op_next->op_next->op_next->op_type == OP_PADSV + || o->op_next->op_next->op_next->op_type == OP_PADAV + || o->op_next->op_next->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE + && (!CopLABEL((COP*)o)) /* Don't mess with labels */ + && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ + ) { + OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; + + pad1 = o->op_next; + ns2 = pad1->op_next; + pad2 = ns2->op_next; + ns3 = pad2->op_next; + + /* we assume here that the op_next chain is the same as + * the op_sibling chain */ + assert(OP_SIBLING(o) == pad1); + assert(OP_SIBLING(pad1) == ns2); + assert(OP_SIBLING(ns2) == pad2); + assert(OP_SIBLING(pad2) == ns3); + + /* create new listop, with children consisting of: + * a new pushmark, pad1, pad2. */ + OP_SIBLING_set(pad2, NULL); + newop = newLISTOP(OP_LIST, 0, pad1, pad2); + newop->op_flags |= OPf_PARENS; + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + newpm = cUNOPx(newop)->op_first; /* pushmark */ + + /* Kill nextstate2 between padop1/padop2 */ + op_free(ns2); + + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + OP_SIBLING_set(o, newop); + OP_SIBLING_set(newop, ns3); + newop->op_lastsib = 0; + + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + /* Ensure pushmark has this flag if padops do */ + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { + o->op_next->op_flags |= OPf_MOD; + } + + break; + } + /* Two NEXTSTATEs in a row serve no purpose. Except if they happen to carry two labels. For now, take the easier option, and skip this optimisation if the first NEXTSTATE has a label. */ @@ -10937,12 +11491,12 @@ Perl_rpeep(pTHX_ OP *o) though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ o->op_opt = 0; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: nothin: - if (oldop && o->op_next) { + if (oldop) { oldop->op_next = o->op_next; o->op_opt = 0; continue; @@ -10988,7 +11542,7 @@ Perl_rpeep(pTHX_ OP *o) OP *rv2av, *q; p = o->op_next; if ( p->op_type == OP_GV - && (gv = cGVOPx_gv(p)) + && (gv = cGVOPx_gv(p)) && isGV(gv) && GvNAMELEN_get(gv) == 1 && *GvNAME_get(gv) == '_' && GvSTASH(gv) == PL_defstash @@ -10997,7 +11551,7 @@ Perl_rpeep(pTHX_ OP *o) && !(rv2av->op_flags & OPf_REF) && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) - && o->op_sibling == rv2av /* these two for Deparse */ + && OP_SIBLING(o) == rv2av /* these two for Deparse */ && cUNOPx(rv2av)->op_first == p ) { q = rv2av->op_next; @@ -11012,8 +11566,8 @@ Perl_rpeep(pTHX_ OP *o) if (!defav) { /* To allow Deparse to pessimise this, it needs to be able * to restore the pushmark's original op_next, which it - * will assume to be the same as op_sibling. */ - if (o->op_next != o->op_sibling) + * will assume to be the same as OP_SIBLING. */ + if (o->op_next != OP_SIBLING(o)) break; p = o; } @@ -11033,7 +11587,7 @@ Perl_rpeep(pTHX_ OP *o) ) break; - /* let $a[N] potentially be optimised into ALEMFAST_LEX + /* let $a[N] potentially be optimised into AELEMFAST_LEX * instead */ if ( p->op_type == OP_PADAV && p->op_next @@ -11105,7 +11659,7 @@ Perl_rpeep(pTHX_ OP *o) */ assert(followop); if (gimme == OPf_WANT_VOID) { - if (followop->op_type == OP_LIST + if (OP_TYPE_IS_OR_WAS(followop, OP_LIST) && gimme == (followop->op_flags & OPf_WANT) && ( followop->op_next->op_type == OP_NEXTSTATE || followop->op_next->op_type == OP_DBSTATE)) @@ -11128,9 +11682,14 @@ Perl_rpeep(pTHX_ OP *o) old_count = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); - assert(oldoldop->op_targ + old_count == base); - if (old_count < OPpPADRANGE_COUNTMASK - count) { + /* Do not assume pad offsets for $c and $d are con- + tiguous in + my ($a,$b,$c); + my ($d,$e,$f); + */ + if ( oldoldop->op_targ + old_count == base + && old_count < OPpPADRANGE_COUNTMASK - count) { base = oldoldop->op_targ; count += old_count; reuse = 1; @@ -11151,12 +11710,13 @@ Perl_rpeep(pTHX_ OP *o) || p->op_type == OP_PADHV) && (p->op_flags & OPf_WANT) == OPf_WANT_VOID && (p->op_private & OPpLVAL_INTRO) == intro + && !(p->op_private & ~OPpLVAL_INTRO) && p->op_next && ( p->op_next->op_type == OP_NEXTSTATE || p->op_next->op_type == OP_DBSTATE) && count < OPpPADRANGE_COUNTMASK + && base + count == p->op_targ ) { - assert(base + count == p->op_targ); count++; followop = p->op_next; } @@ -11201,7 +11761,7 @@ Perl_rpeep(pTHX_ OP *o) pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0) + (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) { GV *gv; if (cSVOPx(pop)->op_private & OPpCONST_STRICT) @@ -11249,10 +11809,6 @@ Perl_rpeep(pTHX_ OP *o) break; - { - OP *fop; - OP *sop; - #define HV_OR_SCALARHV(op) \ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ ? (op) \ @@ -11271,12 +11827,27 @@ Perl_rpeep(pTHX_ OP *o) case OP_OR: case OP_DOR: fop = cLOGOP->op_first; - sop = fop->op_sibling; + sop = OP_SIBLING(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 || 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. + 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 */ + if (o->op_next && + ( + (IS_AND_OP(o) && IS_OR_OP(o->op_next)) + || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) + ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + ) { + o->op_next = ((LOGOP*)o->op_next)->op_other; + } DEFER(cLOGOP->op_other); o->op_opt = 1; @@ -11323,8 +11894,7 @@ Perl_rpeep(pTHX_ OP *o) if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) fop->op_private |= OPpTRUEBOOL; #undef HV_OR_SCALARHV - /* GERONIMO! */ - } + /* GERONIMO! */ /* FALLTHROUGH */ case OP_MAPWHILE: case OP_GREPWHILE: @@ -11352,6 +11922,11 @@ Perl_rpeep(pTHX_ OP *o) DEFER(cLOOP->op_lastop); break; + case OP_ENTERTRY: + assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); + DEFER(cLOGOPo->op_other); + break; + case OP_SUBST: assert(!(cPMOP->op_pmflags & PMf_ONCE)); while (cPMOP->op_pmstashstartu.op_pmreplstart && @@ -11364,12 +11939,28 @@ Perl_rpeep(pTHX_ OP *o) case OP_SORT: { OP *oright; - if (o->op_flags & OPf_STACKED) { - OP * const kid = - cUNOPx(cLISTOP->op_first->op_sibling)->op_first; - if (kid->op_type == OP_SCOPE - || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)) - DEFER(kLISTOP->op_first); + if (o->op_flags & OPf_SPECIAL) { + /* first arg is a code block */ + OP * const nullop = OP_SIBLING(cLISTOP->op_first); + OP * kid = cUNOPx(nullop)->op_first; + + assert(nullop->op_type == OP_NULL); + assert(kid->op_type == OP_SCOPE + || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); + /* since OP_SORT doesn't have a handy op_other-style + * field that can point directly to the start of the code + * block, store it in the otherwise-unused op_next field + * of the top-level OP_NULL. This will be quicker at + * run-time, and it will also allow us to remove leading + * OP_NULLs by just messing with op_nexts without + * altering the basic op_first/op_sibling layout. */ + kid = kLISTOP->op_first; + assert( + (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + || kid->op_type == OP_STUB + || kid->op_type == OP_ENTER); + nullop->op_next = kLISTOP->op_next; + DEFER(nullop->op_next); } /* check that RHS of sort is a single plain array */ @@ -11381,7 +11972,7 @@ Perl_rpeep(pTHX_ OP *o) break; /* reverse sort ... can be optimised. */ - if (!cUNOPo->op_sibling) { + if (!OP_HAS_SIBLING(cUNOPo)) { /* Nothing follows us on the list. */ OP * const reverse = o->op_next; @@ -11389,7 +11980,7 @@ Perl_rpeep(pTHX_ OP *o) (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { OP * const pushmark = cUNOPx(reverse)->op_first; if (pushmark && (pushmark->op_type == OP_PUSHMARK) - && (cUNOPx(pushmark)->op_sibling == o)) { + && (OP_SIBLING(cUNOPx(pushmark)) == o)) { /* reverse -> pushmark -> sort */ o->op_private |= OPpSORT_REVERSE; op_null(reverse); @@ -11444,7 +12035,7 @@ Perl_rpeep(pTHX_ OP *o) || expushmark->op_targ != OP_PUSHMARK) break; - exlist = (LISTOP *) expushmark->op_sibling; + exlist = (LISTOP *) OP_SIBLING(expushmark); if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; @@ -11457,7 +12048,7 @@ Perl_rpeep(pTHX_ OP *o) if (!theirmark || theirmark->op_type != OP_PUSHMARK) break; - if (theirmark->op_sibling != o) { + if (OP_SIBLING(theirmark) != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ @@ -11472,8 +12063,8 @@ Perl_rpeep(pTHX_ OP *o) if (!ourlast || ourlast->op_next != o) break; - rv2av = ourmark->op_sibling; - if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 + rv2av = OP_SIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av) && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { /* We're just reversing a single array. */ @@ -11521,14 +12112,32 @@ Perl_rpeep(pTHX_ OP *o) if (OP_GIMME(o,0) == G_VOID) { OP *right = cBINOP->op_first; if (right) { - OP *left = right->op_sibling; + /* sassign + * RIGHT + * substr + * pushmark + * arg1 + * arg2 + * ... + * becomes + * + * ex-sassign + * substr + * pushmark + * RIGHT + * arg1 + * arg2 + * ... + */ + OP *left = OP_SIBLING(right); 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; + /* cut out right */ + op_sibling_splice(o, NULL, 1, NULL); + /* and insert it as second child of OP_SUBSTR */ + op_sibling_splice(left, cBINOPx(left)->op_first, 0, + right); left->op_private |= OPpSUBSTR_REPL_FIRST; left->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; @@ -11539,15 +12148,23 @@ Perl_rpeep(pTHX_ OP *o) case OP_CUSTOM: { Perl_cpeep_t cpeep = - XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep); + XopENTRYCUSTOM(o, xop_peep); if (cpeep) cpeep(aTHX_ o, oldop); break; } } - oldoldop = oldop; - oldop = o; + /* did we just null the current op? If so, re-process it to handle + * eliding "empty" ops from the chain */ + if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { + o->op_opt = 0; + o = oldop; + } + else { + oldoldop = oldop; + oldop = o; + } } LEAVE; } @@ -11562,14 +12179,17 @@ Perl_peep(pTHX_ OP *o) =head1 Custom Operators =for apidoc Ao||custom_op_xop -Return the XOP structure for a given custom op. This function should be +Return the XOP structure for a given custom op. This macro should be considered internal to OP_NAME and the other access macros: use them instead. +This macro does call a function. Prior +to 5.19.6, this was implemented as a +function. =cut */ -const XOP * -Perl_custom_op_xop(pTHX_ const OP *o) +XOPRETANY +Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) { SV *keysv; HE *he = NULL; @@ -11577,7 +12197,7 @@ Perl_custom_op_xop(pTHX_ const OP *o) static const XOP xop_null = { 0, 0, 0, 0, 0 }; - PERL_ARGS_ASSERT_CUSTOM_OP_XOP; + PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD; assert(o->op_type == OP_CUSTOM); /* This is wrong. It assumes a function pointer can be cast to IV, @@ -11609,18 +12229,68 @@ Perl_custom_op_xop(pTHX_ const OP *o) XopENTRY_set(xop, xop_desc, savepvn(pv, l)); } Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); - return xop; } - - if (!he) return &xop_null; - - xop = INT2PTR(XOP *, SvIV(HeVAL(he))); - return xop; + else { + if (!he) + xop = (XOP *)&xop_null; + else + xop = INT2PTR(XOP *, SvIV(HeVAL(he))); + } + { + XOPRETANY any; + if(field == XOPe_xop_ptr) { + any.xop_ptr = xop; + } else { + const U32 flags = XopFLAGS(xop); + if(flags & field) { + switch(field) { + case XOPe_xop_name: + any.xop_name = xop->xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = xop->xop_desc; + break; + case XOPe_xop_class: + any.xop_class = xop->xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = xop->xop_peep; + break; + default: + NOT_REACHED; + break; + } + } else { + switch(field) { + case XOPe_xop_name: + any.xop_name = XOPd_xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = XOPd_xop_desc; + break; + case XOPe_xop_class: + any.xop_class = XOPd_xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = XOPd_xop_peep; + break; + default: + NOT_REACHED; + break; + } + } + } + /* Some gcc releases emit 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. */ + return any; + } } /* =for apidoc Ao||custom_op_register -Register a custom op. See L. +Register a custom op. See L. =cut */ @@ -11643,13 +12313,13 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) } /* -=head1 Functions in file op.c =for apidoc core_prototype + This function assigns the prototype of the named core function to C, or to a new mortal SV if C is NULL. It returns the modified C, or NULL if the core function has no prototype. C is a code as returned -by C. It must not be equal to 0 or -KEY_CORE. +by C. It must not be equal to 0. =cut */ @@ -11666,7 +12336,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, PERL_ARGS_ASSERT_CORE_PROTOTYPE; - assert (code && code != -KEY_CORE); + assert (code); if (!sv) sv = sv_newmortal(); @@ -11785,7 +12455,7 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, OP_SSELECT), coresub_op(coreargssv, 0, OP_SELECT) ); - /* FALL THROUGH */ + /* FALLTHROUGH */ default: switch (PL_opargs[opnum] & OA_CLASS_MASK) { case OA_BASEOP: @@ -11859,7 +12529,7 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, is_const ? "Constant subroutine %"SVf" redefined" : "Subroutine %"SVf" redefined", - name); + SVfARG(name)); } /* @@ -11883,6 +12553,18 @@ pointer to the next function in the chain will be stored. The value of I is written into the L array, while the value previously stored there is written to I<*old_checker_p>. +The function should be defined like this: + + static OP *new_checker(pTHX_ OP *op) { ... } + +It is intended to be called in this manner: + + new_checker(aTHX_ op) + +I should be defined like this: + + static Perl_check_t old_checker_p; + L is global to an entire process, and a module wishing to hook op checking may find itself invoked more than once per process, typically in different threads. To handle that situation, this function @@ -11917,6 +12599,7 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, { dVAR; + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_WRAP_OP_CHECKER; if (*old_checker_p) return; OP_CHECK_MUTEX_LOCK; @@ -11933,7 +12616,6 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, static void const_sv_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; SV *const sv = MUTABLE_SV(XSANY.any_ptr); PERL_UNUSED_ARG(items); @@ -11948,7 +12630,6 @@ const_sv_xsub(pTHX_ CV* cv) static void const_av_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; AV * const av = MUTABLE_AV(XSANY.any_ptr); SP -= items; @@ -11962,7 +12643,7 @@ const_av_xsub(pTHX_ CV* cv) Perl_croak(aTHX_ "Magical list constants are not supported"); if (GIMME_V != G_ARRAY) { EXTEND(SP, 1); - ST(0) = newSViv((IV)AvFILLp(av)+1); + ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); XSRETURN(1); } EXTEND(SP, AvFILLp(av)+1);