Mercurial > repo
diff perl-5.22.2/op.c @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
| author | HackBot |
|---|---|
| date | Sat, 14 May 2016 14:54:38 +0000 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/perl-5.22.2/op.c Sat May 14 14:54:38 2016 +0000 @@ -0,0 +1,14518 @@ +#line 2 "op.c" +/* op.c + * + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was + * our Mr. Bilbo's first cousin on the mother's side (her mother being the + * youngest of the Old Took's daughters); and Mr. Drogo was his second + * cousin. So Mr. Frodo is his first *and* second cousin, once removed + * either way, as the saying is, if you follow me.' --the Gaffer + * + * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] + */ + +/* This file contains the functions that create, manipulate and optimize + * the OP structures that hold a compiled perl program. + * + * A Perl program is compiled into a tree of OPs. Each op contains + * structural pointers (eg to its siblings and the next op in the + * execution sequence), a pointer to the function that would execute the + * op, plus any data specific to that op. For example, an OP_CONST op + * points to the pp_const() function and to an SV containing the constant + * value. When pp_const() is executed, its job is to push that SV onto the + * stack. + * + * OPs are mainly created by the newFOO() functions, which are mainly + * called from the parser (in perly.y) as the code is parsed. For example + * the Perl code $a + $b * $c would cause the equivalent of the following + * to be called (oversimplifying a bit): + * + * newBINOP(OP_ADD, flags, + * newSVREF($a), + * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c)) + * ) + * + * Note that during the build of miniperl, a temporary copy of this file + * is made, called opmini.c. + */ + +/* +Perl's compiler is essentially a 3-pass compiler with interleaved phases: + + A bottom-up pass + A top-down pass + An execution-order pass + +The bottom-up pass is represented by all the "newOP" routines and +the ck_ routines. The bottom-upness is actually driven by yacc. +So at the point that a ck_ routine fires, we have no idea what the +context is, either upward in the syntax tree, or either forward or +backward in the execution order. (The bottom-up parser builds that +part of the execution order it knows about, but if you follow the "next" +links around, you'll find it's actually a closed loop through the +top level node.) + +Whenever the bottom-up parser gets to a node that supplies context to +its components, it invokes that portion of the top-down pass that applies +to that part of the subtree (and marks the top node as processed, so +if a node further up supplies context, it doesn't have to take the +plunge again). As a particular subcase of this, as the new node is +built, it takes all the closed execution loops of its subcomponents +and links them into a new closed loop for the higher level node. But +it's still not the real execution order. + +The actual execution order is not known till we get a grammar reduction +to a top-level unit like a subroutine or file that will be called by +"name" rather than via a "next" pointer. At that point, we can call +into peep() to do that code's portion of the 3rd pass. It has to be +recursive, but it's recursive on basic blocks, not on tree nodes. +*/ + +/* To implement user lexical pragmas, there needs to be a way at run time to + get the compile time state of %^H for that block. Storing %^H in every + block (or even COP) would be very expensive, so a different approach is + taken. The (running) state of %^H is serialised into a tree of HE-like + structs. Stores into %^H are chained onto the current leaf as a struct + refcounted_he * with the key and the value. Deletes from %^H are saved + with a value of PL_sv_placeholder. The state of %^H at any point can be + turned back into a regular HV by walking back up the tree from that point's + leaf, ignoring any key you've already seen (placeholder or not), storing + the rest into the HV structure, then removing the placeholders. Hence + memory is only used to store the %^H deltas from the enclosing COP, rather + than the entire %^H on each COP. + + To cause actions on %^H to write out the serialisation records, it has + magic type 'H'. This magic (itself) does nothing, but its presence causes + the values to gain magic type 'h', which has entries for set and clear. + C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store + record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS> + saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that + it will be correctly restored when any inner compiling scope is exited. +*/ + +#include "EXTERN.h" +#define PERL_IN_OP_C +#include "perl.h" +#include "keywords.h" +#include "feature.h" +#include "regcomp.h" + +#define CALL_PEEP(o) PL_peepp(aTHX_ o) +#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) +#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) + +/* Used to avoid recursion through the op tree in scalarvoid() and + op_free() +*/ + +#define DEFERRED_OP_STEP 100 +#define DEFER_OP(o) \ + STMT_START { \ + if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \ + defer_stack_alloc += DEFERRED_OP_STEP; \ + assert(defer_stack_alloc > 0); \ + Renew(defer_stack, defer_stack_alloc, OP *); \ + } \ + defer_stack[++defer_ix] = o; \ + } STMT_END + +#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL) + +/* 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 +# define PERL_SLAB_SIZE 128 +# define PERL_MAX_SLAB_SIZE 4096 +# include <sys/mman.h> +#endif + +#ifndef PERL_SLAB_SIZE +# define PERL_SLAB_SIZE 64 +#endif +#ifndef PERL_MAX_SLAB_SIZE +# define PERL_MAX_SLAB_SIZE 2048 +#endif + +/* rounds up to nearest pointer */ +#define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *)) +#define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o))) + +static OPSLAB * +S_new_slab(pTHX_ size_t sz) +{ +#ifdef PERL_DEBUG_READONLY_OPS + OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *), + PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0); + DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n", + (unsigned long) sz, slab)); + if (slab == MAP_FAILED) { + perror("mmap failed"); + abort(); + } + slab->opslab_size = (U16)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; +} + +/* requires double parens and aTHX_ */ +#define DEBUG_S_warn(args) \ + DEBUG_S( \ + PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ + ) + +void * +Perl_Slab_Alloc(pTHX_ size_t sz) +{ + OPSLAB *slab; + OPSLAB *slab2; + OPSLOT *slot; + OP *o; + size_t opsz, space; + + /* We only allocate ops from the slab during subroutine compilation. + We find the slab via PL_compcv, hence that must be non-NULL. It could + also be pointing to a subroutine which is now fully set up (CvROOT() + pointing to the top of the optree for that sub), or a subroutine + which isn't using the slab allocator. If our sanity checks aren't met, + 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))) + { + 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 + unneeded at runtime. Once a subroutine is constructed, the slabs are + accessed via CvROOT(). So if CvSTART() is NULL, no slab has been + allocated yet. See the commit message for 8be227ab5eaa23f2 for more + details. */ + if (!CvSTART(PL_compcv)) { + CvSTART(PL_compcv) = + (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + } + else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; + + opsz = SIZE_TO_PSIZE(sz); + sz = opsz + OPSLOT_HEADER_P; + + /* The slabs maintain a free list of OPs. In particular, constant folding + will free up OPs, so it makes sense to re-use them where possible. A + freed up slot is used in preference to a new allocation. */ + if (slab->opslab_freed) { + OP **too = &slab->opslab_freed; + o = *too; + 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", (void*)o)); } + } + if (o) { + *too = o->op_next; + Zero(o, opsz, I32 *); + o->op_slabbed = 1; + goto gotit; + } + } + +#define INIT_OPSLOT \ + slot->opslot_slab = slab; \ + slot->opslot_next = slab2->opslab_first; \ + slab2->opslab_first = slot; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 + + /* The partially-filled slab is next in the chain. */ + slab2 = slab->opslab_next ? slab->opslab_next : slab; + if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) { + /* Remaining space is too small. */ + + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { + slot = &slab2->opslab_slots; + INIT_OPSLOT; + o->op_type = OP_FREED; + o->op_next = slab->opslab_freed; + slab->opslab_freed = o; + } + + /* Create a new slab. Make this one twice as big. */ + slot = slab2->opslab_first; + while (slot->opslot_next) slot = slot->opslot_next; + slab2 = S_new_slab(aTHX_ + (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE + ? PERL_MAX_SLAB_SIZE + : (DIFF(slab2, slot)+1)*2); + slab2->opslab_next = slab->opslab_next; + slab->opslab_next = slab2; + } + assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz); + + /* Create a new op slot */ + slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz); + assert(slot >= &slab2->opslab_slots); + if (DIFF(&slab2->opslab_slots, slot) + < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) + slot = &slab2->opslab_slots; + INIT_OPSLOT; + DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); + + gotit: +#ifdef PERL_OP_PARENT + /* moresib == 0, op_sibling == 0 implies a solitary unattached op */ + assert(!o->op_moresib); + assert(!o->op_sibparent); +#endif + + return (void *)o; +} + +#undef INIT_OPSLOT + +#ifdef PERL_DEBUG_READONLY_OPS +void +Perl_Slab_to_ro(pTHX_ OPSLAB *slab) +{ + PERL_ARGS_ASSERT_SLAB_TO_RO; + + if (slab->opslab_readonly) return; + slab->opslab_readonly = 1; + for (; slab; slab = slab->opslab_next) { + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", + (unsigned long) slab->opslab_size, slab));*/ + if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ)) + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab, + (unsigned long)slab->opslab_size, errno); + } +} + +void +Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) +{ + OPSLAB *slab2; + + PERL_ARGS_ASSERT_SLAB_TO_RW; + + if (!slab->opslab_readonly) return; + slab2 = slab; + for (; slab2; slab2 = slab2->opslab_next) { + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", + (unsigned long) size, slab2));*/ + if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *), + PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab, + (unsigned long)slab2->opslab_size, errno); + } + } + slab->opslab_readonly = 0; +} + +#else +# define Slab_to_rw(op) NOOP +#endif + +/* This cannot possibly be right, but it was copied from the old slab + allocator, to which it was originally added, without explanation, in + commit 083fcd5. */ +#ifdef NETWARE +# define PerlMemShared PerlMem +#endif + +void +Perl_Slab_Free(pTHX_ void *op) +{ + OP * const o = (OP *)op; + OPSLAB *slab; + + PERL_ARGS_ASSERT_SLAB_FREE; + + if (!o->op_slabbed) { + if (!o->op_static) + PerlMemShared_free(op); + return; + } + + slab = OpSLAB(o); + /* If this op is already freed, our refcount will get screwy. */ + assert(o->op_type != OP_FREED); + 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", (void*)o, (void*)slab)); + OpslabREFCNT_dec_padok(slab); +} + +void +Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) +{ + const bool havepad = !!PL_comppad; + PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; + if (havepad) { + ENTER; + PAD_SAVE_SETNULLPAD(); + } + opslab_free(slab); + if (havepad) LEAVE; +} + +void +Perl_opslab_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + PERL_ARGS_ASSERT_OPSLAB_FREE; + PERL_UNUSED_CONTEXT; + DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); + assert(slab->opslab_refcnt == 1); + do { + slab2 = slab->opslab_next; +#ifdef DEBUGGING + slab->opslab_refcnt = ~(size_t)0; +#endif +#ifdef PERL_DEBUG_READONLY_OPS + DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", + (void*)slab)); + if (munmap(slab, slab->opslab_size * sizeof(I32 *))) { + perror("munmap failed"); + abort(); + } +#else + PerlMemShared_free(slab); +#endif + slab = slab2; + } while (slab); +} + +void +Perl_opslab_force_free(pTHX_ OPSLAB *slab) +{ + OPSLAB *slab2; + OPSLOT *slot; +#ifdef DEBUGGING + size_t savestack_count = 0; +#endif + PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; + slab2 = slab; + do { + for (slot = slab2->opslab_first; + slot->opslot_next; + slot = slot->opslot_next) { + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree +#ifdef DEBUGGING + && ++savestack_count +#endif + ) + ) { + assert(slot->opslot_op.op_slabbed); + op_free(&slot->opslot_op); + if (slab->opslab_refcnt == 1) goto free; + } + } + } while ((slab2 = slab2->opslab_next)); + /* > 1 because the CV still holds a reference count. */ + if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */ +#ifdef DEBUGGING + assert(savestack_count == slab->opslab_refcnt-1); +#endif + /* Remove the CV’s reference count. */ + slab->opslab_refcnt--; + return; + } + free: + opslab_free(slab); +} + +#ifdef PERL_DEBUG_READONLY_OPS +OP * +Perl_op_refcnt_inc(pTHX_ OP *o) +{ + if(o) { + OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; + if (slab && slab->opslab_readonly) { + Slab_to_rw(slab); + ++o->op_targ; + Slab_to_ro(slab); + } else { + ++o->op_targ; + } + } + return o; + +} + +PADOFFSET +Perl_op_refcnt_dec(pTHX_ OP *o) +{ + PADOFFSET result; + OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; + + PERL_ARGS_ASSERT_OP_REFCNT_DEC; + + if (slab && slab->opslab_readonly) { + Slab_to_rw(slab); + result = --o->op_targ; + Slab_to_ro(slab); + } else { + result = --o->op_targ; + } + return result; +} +#endif +/* + * In the following definition, the ", (OP*)0" is just to make the compiler + * think the expression is of the right type: croak actually does a Siglongjmp. + */ +#define CHECKOP(type,o) \ + ((PL_op_mask && PL_op_mask[type]) \ + ? ( op_free((OP*)o), \ + Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ + (OP*)0 ) \ + : PL_check[type](aTHX_ (OP*)o)) + +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) + +#define OpTYPE_set(o,type) \ + STMT_START { \ + o->op_type = (OPCODE)type; \ + o->op_ppaddr = PL_ppaddr[type]; \ + } STMT_END + +STATIC OP * +S_no_fh_allowed(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_NO_FH_ALLOWED; + + yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", + OP_DESC(o))); + return o; +} + +STATIC OP * +S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags); + return o; +} + +STATIC OP * +S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) +{ + PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV; + + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags); + return o; +} + +STATIC void +S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid) +{ + PERL_ARGS_ASSERT_BAD_TYPE_PV; + + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", + (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0); +} + +/* remove flags var, its unused in all callers, move to to right end since gv + and kid are always the same */ +STATIC void +S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) +{ + SV * const namesv = cv_name((CV *)gv, NULL, 0); + PERL_ARGS_ASSERT_BAD_TYPE_GV; + + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); +} + +STATIC void +S_no_bareword_allowed(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; + + qerror(Perl_mess(aTHX_ + "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + SVfARG(cSVOPo_sv))); + o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ +} + +/* "register" allocation */ + +PADOFFSET +Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) +{ + PADOFFSET off; + const bool is_our = (PL_parser->in_my == KEY_our); + + PERL_ARGS_ASSERT_ALLOCMY; + + if (flags & ~SVf_UTF8) + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* complain about "my $<special_var>" etc etc */ + if (len && + !(is_our || + isALPHA(name[1]) || + ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || + (name[1] == '_' && (*name == '$' || len > 2)))) + { + if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && isASCII(name[1]) + && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) { + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, + PL_parser->in_my == KEY_state ? "state" : "my")); + } else { + yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, + PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); + } + } + else if (len == 2 && name[1] == '_' && !is_our) + /* diag_listed_as: Use of my $_ is experimental */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC), + "Use of %s $_ is experimental", + PL_parser->in_my == KEY_state + ? "state" + : "my"); + + /* allocate a spare slot and store the name in that slot */ + + off = pad_add_name_pvn(name, len, + (is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0), + PL_parser->in_my_stash, + (is_our + /* $_ is always in main::, even with our */ + ? (PL_curstash && !memEQs(name,len,"$_") + ? PL_curstash + : PL_defstash) + : NULL + ) + ); + /* anon sub prototypes contains state vars should always be cloned, + * otherwise the state var would be shared between anon subs */ + + if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) + CvCLONE_on(PL_compcv); + + return off; +} + +/* +=head1 Optree Manipulation Functions + +=for apidoc alloccopstash + +Available only under threaded builds, this function allocates an entry in +C<PL_stashpad> for the stash passed to it. + +=cut +*/ + +#ifdef USE_ITHREADS +PADOFFSET +Perl_alloccopstash(pTHX_ HV *hv) +{ + PADOFFSET off = 0, o = 1; + bool found_slot = FALSE; + + PERL_ARGS_ASSERT_ALLOCCOPSTASH; + + if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix; + + for (; o < PL_stashpadmax; ++o) { + if (PL_stashpad[o] == hv) return PL_stashpadix = o; + if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV) + found_slot = TRUE, off = o; + } + if (!found_slot) { + Renew(PL_stashpad, PL_stashpadmax + 10, HV *); + Zero(PL_stashpad + PL_stashpadmax, 10, HV *); + off = PL_stashpadmax; + PL_stashpadmax += 10; + } + + PL_stashpad[PL_stashpadix = off] = hv; + return off; +} +#endif + +/* free the body of an op without examining its contents. + * Always use this rather than FreeOp directly */ + +static void +S_op_destroy(pTHX_ OP *o) +{ + FreeOp(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) +{ + dVAR; + OPCODE type; + SSize_t defer_ix = -1; + SSize_t defer_stack_alloc = 0; + OP **defer_stack = NULL; + + do { + + /* Though ops may be freed twice, freeing the op after its slab is a + big no-no. */ + assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); + /* During the forced freeing of ops after compilation failure, kidops + may be freed before their parents. */ + if (!o || o->op_type == OP_FREED) + continue; + + 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. + * Don't bother testing if: + * * the op_ppaddr doesn't match the op; someone may have + * overridden the op and be doing strange things with it; + * * we've errored, as op flags are often left in an + * inconsistent state then. Note that an error when + * compiling the main program leaves PL_parser NULL, so + * we can't spot faults in the main code, onoly + * evaled/required code */ +#ifdef DEBUGGING + if ( o->op_ppaddr == PL_ppaddr[o->op_type] + && PL_parser + && !PL_parser->error_count) + { + assert(!(o->op_private & ~PL_op_private_valid[type])); + } +#endif + + if (o->op_private & OPpREFCOUNTED) { + switch (type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + { + PADOFFSET refcnt; + OP_REFCNT_LOCK; + refcnt = OpREFCNT_dec(o); + OP_REFCNT_UNLOCK; + if (refcnt) { + /* Need to find and remove any pattern match ops from the list + we maintain for reset(). */ + find_and_forget_pmops(o); + continue; + } + } + break; + default: + break; + } + } + + /* Call the op_free hook if it has been set. Do it now so that it's called + * at the right time for refcounted ops, but still before all of the kids + * are freed. */ + CALL_OPFREEHOOK(o); + + if (o->op_flags & OPf_KIDS) { + OP *kid, *nextkid; + for (kid = cUNOPo->op_first; kid; kid = nextkid) { + nextkid = OpSIBLING(kid); /* Get before next freeing kid */ + if (!kid || kid->op_type == OP_FREED) + /* During the forced freeing of ops after + compilation failure, kidops may be freed before + their parents. */ + continue; + if (!(kid->op_flags & OPf_KIDS)) + /* If it has no kids, just free it now */ + op_free(kid); + else + DEFER_OP(kid); + } + } + if (type == OP_NULL) + type = (OPCODE)o->op_targ; + + if (o->op_slabbed) + Slab_to_rw(OpSLAB(o)); + + /* COP* is not cleared by op_clear() so that we may track line + * numbers etc even after null() */ + if (type == OP_NEXTSTATE || type == OP_DBSTATE) { + cop_free((COP*)o); + } + + op_clear(o); + FreeOp(o); +#ifdef DEBUG_LEAKING_SCALARS + if (PL_op == o) + PL_op = NULL; +#endif + } while ( (o = POP_DEFERRED_OP()) ); + + Safefree(defer_stack); +} + +/* S_op_clear_gv(): free a GV attached to an OP */ + +#ifdef USE_ITHREADS +void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp) +#else +void S_op_clear_gv(pTHX_ OP *o, SV**svp) +#endif +{ + + GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV + || o->op_type == OP_MULTIDEREF) +#ifdef USE_ITHREADS + && PL_curpad + ? ((GV*)PAD_SVl(*ixp)) : NULL; +#else + ? (GV*)(*svp) : NULL; +#endif + /* It's possible during global destruction that the GV is freed + before the optree. Whilst the SvREFCNT_inc is happy to bump from + 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 + will trigger an assertion failure, because the entry to sv_clear + checks that the scalar is not already freed. A check of for + !SvIS_FREED(gv) turns out to be invalid, because during global + destruction the reference count can be forced down to zero + (with SVf_BREAK set). In which case raising to 1 and then + dropping to 0 triggers cleanup before it should happen. I + *think* that this might actually be a general, systematic, + weakness of the whole idea of SVf_BREAK, in that code *is* + allowed to raise and lower references during global destruction, + so any *valid* code that happens to do this during global + destruction might well trigger premature cleanup. */ + bool still_valid = gv && SvREFCNT(gv); + + if (still_valid) + SvREFCNT_inc_simple_void(gv); +#ifdef USE_ITHREADS + if (*ixp > 0) { + pad_swipe(*ixp, TRUE); + *ixp = 0; + } +#else + SvREFCNT_dec(*svp); + *svp = NULL; +#endif + if (still_valid) { + int try_downgrade = SvREFCNT(gv) == 2; + SvREFCNT_dec_NN(gv); + if (try_downgrade) + gv_try_downgrade(gv); + } +} + + +void +Perl_op_clear(pTHX_ OP *o) +{ + + dVAR; + + PERL_ARGS_ASSERT_OP_CLEAR; + + switch (o->op_type) { + case OP_NULL: /* Was holding old type, if any. */ + /* FALLTHROUGH */ + case OP_ENTERTRY: + case OP_ENTEREVAL: /* Was holding hints. */ + o->op_targ = 0; + break; + default: + if (!(o->op_flags & OPf_REF) + || (PL_check[o->op_type] != Perl_ck_ftst)) + break; + /* FALLTHROUGH */ + case OP_GVSV: + case OP_GV: + case OP_AELEMFAST: +#ifdef USE_ITHREADS + S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix)); +#else + S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv)); +#endif + break; + case OP_METHOD_REDIR: + case OP_METHOD_REDIR_SUPER: +#ifdef USE_ITHREADS + if (cMETHOPx(o)->op_rclass_targ) { + pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); + cMETHOPx(o)->op_rclass_targ = 0; + } +#else + SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); + cMETHOPx(o)->op_rclass_sv = NULL; +#endif + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv); + cMETHOPx(o)->op_u.op_meth_sv = NULL; +#ifdef USE_ITHREADS + if (o->op_targ) { + pad_swipe(o->op_targ, 1); + o->op_targ = 0; + } +#endif + break; + case OP_CONST: + case OP_HINTSEVAL: + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = NULL; +#ifdef USE_ITHREADS + /** Bug #15654 + Even if op_clear does a pad_free for the target of the op, + pad_free doesn't actually remove the sv that exists in the pad; + instead it lives on. This results in that it could be reused as + a target later on when the pad was reallocated. + **/ + if(o->op_targ) { + pad_swipe(o->op_targ,1); + o->op_targ = 0; + } +#endif + break; + case OP_DUMP: + case OP_GOTO: + case OP_NEXT: + case OP_LAST: + case OP_REDO: + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; + /* FALLTHROUGH */ + case OP_TRANS: + case OP_TRANSR: + if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { + assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR); +#ifdef USE_ITHREADS + if (cPADOPo->op_padix > 0) { + pad_swipe(cPADOPo->op_padix, TRUE); + cPADOPo->op_padix = 0; + } +#else + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = NULL; +#endif + } + else { + PerlMemShared_free(cPVOPo->op_pv); + cPVOPo->op_pv = NULL; + } + break; + case OP_SUBST: + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); + goto clear_pmop; + case OP_PUSHRE: +#ifdef USE_ITHREADS + if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); + } +#else + SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); +#endif + /* FALLTHROUGH */ + case OP_MATCH: + case OP_QR: + clear_pmop: + if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE)) + op_free(cPMOPo->op_code_list); + cPMOPo->op_code_list = NULL; + forget_pmop(cPMOPo); + cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; + /* we use the same protection as the "SAFE" version of the PM_ macros + * here since sv_clean_all might release some PMOPs + * after PL_regex_padav has been cleared + * and the clearing of PL_regex_padav needs to + * happen before sv_clean_all + */ +#ifdef USE_ITHREADS + if(PL_regex_pad) { /* We could be in destruction */ + const IV offset = (cPMOPo)->op_pmoffset; + ReREFCNT_dec(PM_GETRE(cPMOPo)); + PL_regex_pad[offset] = &PL_sv_undef; + sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset, + sizeof(offset)); + } +#else + ReREFCNT_dec(PM_GETRE(cPMOPo)); + PM_SETRE(cPMOPo, NULL); +#endif + + break; + + case OP_MULTIDEREF: + { + UNOP_AUX_item *items = cUNOP_AUXo->op_aux; + UV actions = items->uv; + bool last = 0; + bool is_hash = FALSE; + + while (!last) { + switch (actions & MDEREF_ACTION_MASK) { + + case MDEREF_reload: + actions = (++items)->uv; + continue; + + case MDEREF_HV_padhv_helem: + is_hash = TRUE; + case MDEREF_AV_padav_aelem: + pad_free((++items)->pad_offset); + goto do_elem; + + case MDEREF_HV_gvhv_helem: + is_hash = TRUE; + case MDEREF_AV_gvav_aelem: +#ifdef USE_ITHREADS + S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); +#else + S_op_clear_gv(aTHX_ o, &((++items)->sv)); +#endif + goto do_elem; + + case MDEREF_HV_gvsv_vivify_rv2hv_helem: + is_hash = TRUE; + case MDEREF_AV_gvsv_vivify_rv2av_aelem: +#ifdef USE_ITHREADS + S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); +#else + S_op_clear_gv(aTHX_ o, &((++items)->sv)); +#endif + goto do_vivify_rv2xv_elem; + + case MDEREF_HV_padsv_vivify_rv2hv_helem: + is_hash = TRUE; + case MDEREF_AV_padsv_vivify_rv2av_aelem: + pad_free((++items)->pad_offset); + goto do_vivify_rv2xv_elem; + + case MDEREF_HV_pop_rv2hv_helem: + case MDEREF_HV_vivify_rv2hv_helem: + is_hash = TRUE; + do_vivify_rv2xv_elem: + case MDEREF_AV_pop_rv2av_aelem: + case MDEREF_AV_vivify_rv2av_aelem: + do_elem: + switch (actions & MDEREF_INDEX_MASK) { + case MDEREF_INDEX_none: + last = 1; + break; + case MDEREF_INDEX_const: + if (is_hash) { +#ifdef USE_ITHREADS + /* see RT #15654 */ + pad_swipe((++items)->pad_offset, 1); +#else + SvREFCNT_dec((++items)->sv); +#endif + } + else + items++; + break; + case MDEREF_INDEX_padsv: + pad_free((++items)->pad_offset); + break; + case MDEREF_INDEX_gvsv: +#ifdef USE_ITHREADS + S_op_clear_gv(aTHX_ o, &((++items)->pad_offset)); +#else + S_op_clear_gv(aTHX_ o, &((++items)->sv)); +#endif + break; + } + + if (actions & MDEREF_FLAG_last) + last = 1; + is_hash = FALSE; + + break; + + default: + assert(0); + last = 1; + break; + + } /* switch */ + + actions >>= MDEREF_SHIFT; + } /* while */ + + /* start of malloc is at op_aux[-1], where the length is + * stored */ + PerlMemShared_free(cUNOP_AUXo->op_aux - 1); + } + break; + } + + if (o->op_targ > 0) { + pad_free(o->op_targ); + o->op_targ = 0; + } +} + +STATIC void +S_cop_free(pTHX_ COP* cop) +{ + PERL_ARGS_ASSERT_COP_FREE; + + CopFILE_free(cop); + if (! specialWARN(cop->cop_warnings)) + PerlMemShared_free(cop->cop_warnings); + cophh_free(CopHINTHASH_get(cop)); + if (PL_curcop == cop) + PL_curcop = NULL; +} + +STATIC void +S_forget_pmop(pTHX_ PMOP *const o + ) +{ + HV * const pmstash = PmopSTASH(o); + + PERL_ARGS_ASSERT_FORGET_PMOP; + + if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) { + MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); + if (mg) { + PMOP **const array = (PMOP**) mg->mg_ptr; + U32 count = mg->mg_len / sizeof(PMOP**); + U32 i = count; + + while (i--) { + if (array[i] == o) { + /* Found it. Move the entry at the end to overwrite it. */ + array[i] = array[--count]; + mg->mg_len = count * sizeof(PMOP**); + /* Could realloc smaller at this point always, but probably + not worth it. Probably worth free()ing if we're the + last. */ + if(!count) { + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + } + break; + } + } + } + } + if (PL_curpm == o) + PL_curpm = NULL; +} + +STATIC void +S_find_and_forget_pmops(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS; + + if (o->op_flags & OPf_KIDS) { + OP *kid = cUNOPo->op_first; + while (kid) { + switch (kid->op_type) { + case OP_SUBST: + case OP_PUSHRE: + case OP_MATCH: + case OP_QR: + forget_pmop((PMOP*)kid); + } + find_and_forget_pmops(kid); + kid = OpSIBLING(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) +{ + dVAR; + + PERL_ARGS_ASSERT_OP_NULL; + + if (o->op_type == OP_NULL) + return; + op_clear(o); + o->op_targ = o->op_type; + OpTYPE_set(o, OP_NULL); +} + +void +Perl_op_refcnt_lock(pTHX) +{ +#ifdef USE_ITHREADS + dVAR; +#endif + PERL_UNUSED_CONTEXT; + OP_REFCNT_LOCK; +} + +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/op_sibparent or op_moresib 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. It may passed as NULL if +the splicing doesn't affect the first or last op in the 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 + + +For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>, +see C<OpMORESIB_set>, C<OpLASTSIB_set>, C<OpMAYBESIB_set>. + +=cut +*/ + +OP * +Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) +{ + OP *first; + OP *rest; + OP *last_del = NULL; + OP *last_ins = NULL; + + if (start) + first = OpSIBLING(start); + else if (!parent) + goto no_parent; + else + first = cLISTOPx(parent)->op_first; + + assert(del_count >= -1); + + if (del_count && first) { + last_del = first; + while (--del_count && OpHAS_SIBLING(last_del)) + last_del = OpSIBLING(last_del); + rest = OpSIBLING(last_del); + OpLASTSIB_set(last_del, NULL); + } + else + rest = first; + + if (insert) { + last_ins = insert; + while (OpHAS_SIBLING(last_ins)) + last_ins = OpSIBLING(last_ins); + OpMAYBESIB_set(last_ins, rest, NULL); + } + else + insert = rest; + + if (start) { + OpMAYBESIB_set(start, insert, NULL); + } + else { + if (!parent) + goto no_parent; + cLISTOPx(parent)->op_first = insert; + if (insert) + parent->op_flags |= OPf_KIDS; + else + parent->op_flags &= ~OPf_KIDS; + } + + if (!rest) { + /* update op_last etc */ + U32 type; + OP *lastop; + + if (!parent) + goto no_parent; + + /* ought to use OP_CLASS(parent) here, but that can't handle + * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't + * either */ + type = parent->op_type; + if (type == OP_CUSTOM) { + dTHX; + type = XopENTRYCUSTOM(parent, xop_class); + } + else { + 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) + OpLASTSIB_set(lastop, parent); + } + return last_del ? first : NULL; + + no_parent: + Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent"); +} + + +#ifdef PERL_OP_PARENT + +/* +=for apidoc op_parent + +Returns the parent OP of o, if it has a parent. Returns NULL otherwise. +This function is only available on perls built with C<-DPERL_OP_PARENT>. + +=cut +*/ + +OP * +Perl_op_parent(OP *o) +{ + PERL_ARGS_ASSERT_OP_PARENT; + while (OpHAS_SIBLING(o)) + o = OpSIBLING(o); + return o->op_sibparent; +} + +#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) +{ + dVAR; + LOGOP *logop; + OP *kid = first; + NewOp(1101, logop, 1, LOGOP); + OpTYPE_set(logop, type); + logop->op_first = first; + logop->op_other = other; + logop->op_flags = OPf_KIDS; + while (kid && OpHAS_SIBLING(kid)) + kid = OpSIBLING(kid); + if (kid) + OpLASTSIB_set(kid, (OP*)logop); + return logop; +} + + +/* Contextualizers */ + +/* +=for apidoc Am|OP *|op_contextualize|OP *o|I32 context + +Applies a syntactic context to an op tree representing an expression. +I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>, +or C<G_VOID> to specify the context to apply. The modified op tree +is returned. + +=cut +*/ + +OP * +Perl_op_contextualize(pTHX_ OP *o, I32 context) +{ + PERL_ARGS_ASSERT_OP_CONTEXTUALIZE; + switch (context) { + case G_SCALAR: return scalar(o); + case G_ARRAY: return list(o); + case G_VOID: return scalarvoid(o); + default: + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); + } +} + +/* + +=for apidoc Am|OP*|op_linklist|OP *o +This function is the implementation of the L</LINKLIST> macro. It should +not be called directly. + +=cut +*/ + +OP * +Perl_op_linklist(pTHX_ OP *o) +{ + OP *first; + + PERL_ARGS_ASSERT_OP_LINKLIST; + + if (o->op_next) + return o->op_next; + + /* establish postfix order */ + first = cUNOPo->op_first; + if (first) { + OP *kid; + o->op_next = LINKLIST(first); + kid = first; + for (;;) { + OP *sibl = OpSIBLING(kid); + if (sibl) { + kid->op_next = LINKLIST(sibl); + kid = sibl; + } else { + kid->op_next = o; + break; + } + } + } + else + o->op_next = o; + + return o->op_next; +} + +static OP * +S_scalarkids(pTHX_ OP *o) +{ + if (o && o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + scalar(kid); + } + return o; +} + +STATIC OP * +S_scalarboolean(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_SCALARBOOLEAN; + + if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST + && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) { + if (ckWARN(WARN_SYNTAX)) { + const line_t oldline = CopLINE(PL_curcop); + + if (PL_parser && PL_parser->copline != NOLINE) { + /* This ensures that warnings are reported at the first line + of the conditional, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); + CopLINE_set(PL_curcop, oldline); + } + } + 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 = OpSIBLING(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(OpSIBLING(kid)); + name = S_op_varname(aTHX_ OpSIBLING(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) +{ + OP *kid; + + /* assumes no premature commitment */ + if (!o || (PL_parser && PL_parser->error_count) + || (o->op_flags & OPf_WANT) + || o->op_type == OP_RETURN) + { + return o; + } + + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; + + switch (o->op_type) { + case OP_REPEAT: + scalar(cBINOPo->op_first); + if (o->op_private & OPpREPEAT_DOLIST) { + kid = cLISTOPx(cUNOPo->op_first)->op_first; + assert(kid->op_type == OP_PUSHMARK); + if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) { + op_null(cLISTOPx(cUNOPo->op_first)->op_first); + o->op_private &=~ OPpREPEAT_DOLIST; + } + } + break; + case OP_OR: + case OP_AND: + case OP_COND_EXPR: + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) + scalar(kid); + break; + /* FALLTHROUGH */ + case OP_SPLIT: + case OP_MATCH: + case OP_QR: + case OP_SUBST: + case OP_NULL: + default: + if (o->op_flags & OPf_KIDS) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) + scalar(kid); + } + break; + case OP_LEAVE: + case OP_LEAVETRY: + kid = cLISTOPo->op_first; + scalar(kid); + kid = OpSIBLING(kid); + do_kids: + while (kid) { + OP *sib = OpSIBLING(kid); + if (sib && kid->op_type != OP_LEAVEWHEN + && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL + || ( sib->op_targ != OP_NEXTSTATE + && sib->op_targ != OP_DBSTATE ))) + scalarvoid(kid); + else + scalar(kid); + kid = sib; + } + PL_curcop = &PL_compiling; + break; + case OP_SCOPE: + case OP_LINESEQ: + case OP_LIST: + kid = cLISTOPo->op_first; + goto do_kids; + 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 = OpSIBLING(kid); /* get past pushmark */ + assert(OpSIBLING(kid)); + name = S_op_varname(aTHX_ OpSIBLING(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; +} + +OP * +Perl_scalarvoid(pTHX_ OP *arg) +{ + dVAR; + OP *kid; + SV* sv; + U8 want; + SSize_t defer_stack_alloc = 0; + SSize_t defer_ix = -1; + OP **defer_stack = NULL; + OP *o = arg; + + PERL_ARGS_ASSERT_SCALARVOID; + + do { + SV *useless_sv = NULL; + const char* useless = NULL; + + if (o->op_type == OP_NEXTSTATE + || o->op_type == OP_DBSTATE + || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE))) + PL_curcop = (COP*)o; /* for warning below */ + + /* assumes no premature commitment */ + want = o->op_flags & OPf_WANT; + if ((want && want != OPf_WANT_SCALAR) + || (PL_parser && PL_parser->error_count) + || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN) + { + continue; + } + + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { + /* newASSIGNOP has already applied scalar context, which we + leave, as if this op is inside SASSIGN. */ + continue; + } + + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + switch (o->op_type) { + default: + if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) + break; + /* FALLTHROUGH */ + case OP_REPEAT: + if (o->op_flags & OPf_STACKED) + break; + if (o->op_type == OP_REPEAT) + scalar(cBINOPo->op_first); + goto func_ops; + case OP_SUBSTR: + if (o->op_private == 4) + break; + /* FALLTHROUGH */ + case OP_WANTARRAY: + case OP_GV: + case OP_SMARTMATCH: + case OP_AV2ARYLEN: + case OP_REF: + case OP_REFGEN: + case OP_SREFGEN: + case OP_DEFINED: + case OP_HEX: + case OP_OCT: + case OP_LENGTH: + case OP_VEC: + case OP_INDEX: + case OP_RINDEX: + case OP_SPRINTF: + case OP_KVASLICE: + case OP_KVHSLICE: + case OP_UNPACK: + case OP_PACK: + case OP_JOIN: + case OP_LSLICE: + case OP_ANONLIST: + case OP_ANONHASH: + case OP_SORT: + case OP_REVERSE: + case OP_RANGE: + case OP_FLIP: + case OP_FLOP: + case OP_CALLER: + case OP_FILENO: + case OP_EOF: + case OP_TELL: + case OP_GETSOCKNAME: + case OP_GETPEERNAME: + case OP_READLINK: + case OP_TELLDIR: + case OP_GETPPID: + case OP_GETPGRP: + case OP_GETPRIORITY: + case OP_TIME: + case OP_TMS: + case OP_LOCALTIME: + case OP_GMTIME: + case OP_GHBYNAME: + case OP_GHBYADDR: + case OP_GHOSTENT: + case OP_GNBYNAME: + case OP_GNBYADDR: + case OP_GNETENT: + case OP_GPBYNAME: + case OP_GPBYNUMBER: + case OP_GPROTOENT: + case OP_GSBYNAME: + case OP_GSBYPORT: + case OP_GSERVENT: + case OP_GPWNAM: + case OP_GPWUID: + case OP_GGRNAM: + case OP_GGRGID: + case OP_GETLOGIN: + case OP_PROTOTYPE: + case OP_RUNCV: + func_ops: + useless = OP_DESC(o); + break; + + case OP_GVSV: + case OP_PADSV: + case OP_PADAV: + case OP_PADHV: + case OP_PADANY: + case OP_AELEM: + case OP_AELEMFAST: + case OP_AELEMFAST_LEX: + case OP_ASLICE: + case OP_HELEM: + case OP_HSLICE: + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) + /* Otherwise it's "Useless use of grep iterator" */ + useless = OP_DESC(o); + break; + + case OP_SPLIT: + kid = cLISTOPo->op_first; + if (kid && kid->op_type == OP_PUSHRE + && !kid->op_targ + && !(o->op_flags & OPf_STACKED) +#ifdef USE_ITHREADS + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff +#else + && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv +#endif + ) + useless = OP_DESC(o); + break; + + case OP_NOT: + kid = cUNOPo->op_first; + if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST && + kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) { + goto func_ops; + } + useless = "negative pattern binding (!~)"; + break; + + case OP_SUBST: + if (cPMOPo->op_pmflags & PMf_NONDESTRUCT) + useless = "non-destructive substitution (s///r)"; + break; + + case OP_TRANSR: + useless = "non-destructive transliteration (tr///r)"; + break; + + case OP_RV2GV: + case OP_RV2SV: + case OP_RV2AV: + case OP_RV2HV: + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && + (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE)) + useless = "a variable"; + break; + + case OP_CONST: + sv = cSVOPo_sv; + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + else { + if (ckWARN(WARN_VOID)) { + NV nv; + /* don't warn on optimised away booleans, eg + * use constant Foo, 5; Foo || print; */ + if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) + useless = NULL; + /* the constants 0 and 1 are permitted as they are + conventionally used as dummies in constructs like + 1 while some_condition_with_side_effects; */ + else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0)) + useless = NULL; + else if (SvPOK(sv)) { + SV * const dsv = newSVpvs(""); + useless_sv + = Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, SvPVX_const(sv), + SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP + | PERL_PV_ESCAPE_NOCLEAR + | PERL_PV_ESCAPE_UNI_DETECT)); + SvREFCNT_dec_NN(dsv); + } + else if (SvOK(sv)) { + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv)); + } + else + useless = "a constant (undef)"; + } + } + op_null(o); /* don't execute or even remember it */ + break; + + case OP_POSTINC: + OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */ + break; + + case OP_POSTDEC: + OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */ + break; + + case OP_I_POSTINC: + OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */ + break; + + case OP_I_POSTDEC: + OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */ + break; + + case OP_SASSIGN: { + OP *rv2gv; + UNOP *refgen, *rv2cv; + LISTOP *exlist; + + if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) + break; + + rv2gv = ((BINOP *)o)->op_last; + if (!rv2gv || rv2gv->op_type != OP_RV2GV) + break; + + refgen = (UNOP *)((BINOP *)o)->op_first; + + if (!refgen || (refgen->op_type != OP_REFGEN + && refgen->op_type != OP_SREFGEN)) + break; + + exlist = (LISTOP *)refgen->op_first; + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_first->op_type != OP_PUSHMARK + && exlist->op_first != exlist->op_last) + break; + + rv2cv = (UNOP*)exlist->op_last; + + if (rv2cv->op_type != OP_RV2CV) + break; + + assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0); + assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0); + assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0); + + o->op_private |= OPpASSIGN_CV_TO_GV; + rv2gv->op_private |= OPpDONT_INIT_GV; + rv2cv->op_private |= OPpMAY_RETURN_CONSTANT; + + break; + } + + case OP_AASSIGN: { + inplace_aassign(o); + break; + } + + case OP_OR: + case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS)) { + if (o->op_type == OP_AND) { + OpTYPE_set(o, OP_OR); + } else { + OpTYPE_set(o, OP_AND); + } + op_null(kid); + } + /* FALLTHROUGH */ + + case OP_DOR: + case OP_COND_EXPR: + case OP_ENTERGIVEN: + case OP_ENTERWHEN: + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) + if (!(kid->op_flags & OPf_KIDS)) + scalarvoid(kid); + else + DEFER_OP(kid); + break; + + case OP_NULL: + if (o->op_flags & OPf_STACKED) + break; + /* FALLTHROUGH */ + case OP_NEXTSTATE: + case OP_DBSTATE: + case OP_ENTERTRY: + case OP_ENTER: + if (!(o->op_flags & OPf_KIDS)) + break; + /* FALLTHROUGH */ + case OP_SCOPE: + case OP_LEAVE: + case OP_LEAVETRY: + case OP_LEAVELOOP: + case OP_LINESEQ: + case OP_LEAVEGIVEN: + case OP_LEAVEWHEN: + kids: + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + if (!(kid->op_flags & OPf_KIDS)) + scalarvoid(kid); + else + DEFER_OP(kid); + break; + case OP_LIST: + /* If the first kid after pushmark is something that the padrange + optimisation would reject, then null the list and the pushmark. + */ + if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK + && ( !(kid = OpSIBLING(kid)) + || ( kid->op_type != OP_PADSV + && kid->op_type != OP_PADAV + && kid->op_type != OP_PADHV) + || kid->op_private & ~OPpLVAL_INTRO + || !(kid = OpSIBLING(kid)) + || ( kid->op_type != OP_PADSV + && kid->op_type != OP_PADAV + && kid->op_type != OP_PADHV) + || kid->op_private & ~OPpLVAL_INTRO) + ) { + op_null(cUNOPo->op_first); /* NULL the pushmark */ + op_null(o); /* NULL the list */ + } + goto kids; + case OP_ENTEREVAL: + scalarkids(o); + break; + case OP_SCALAR: + scalar(o); + break; + } + + if (useless_sv) { + /* mortalise it, in case warnings are fatal. */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Useless use of %"SVf" in void context", + SVfARG(sv_2mortal(useless_sv))); + } + else if (useless) { + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Useless use of %s in void context", + useless); + } + } while ( (o = POP_DEFERRED_OP()) ); + + Safefree(defer_stack); + + return arg; +} + +static OP * +S_listkids(pTHX_ OP *o) +{ + if (o && o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + list(kid); + } + return o; +} + +OP * +Perl_list(pTHX_ OP *o) +{ + OP *kid; + + /* assumes no premature commitment */ + if (!o || (o->op_flags & OPf_WANT) + || (PL_parser && PL_parser->error_count) + || o->op_type == OP_RETURN) + { + return o; + } + + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { + return o; /* As if inside SASSIGN */ + } + + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; + + switch (o->op_type) { + case OP_FLOP: + list(cBINOPo->op_first); + break; + case OP_REPEAT: + if (o->op_private & OPpREPEAT_DOLIST + && !(o->op_flags & OPf_STACKED)) + { + list(cBINOPo->op_first); + kid = cBINOPo->op_last; + if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv) + && SvIVX(kSVOP_sv) == 1) + { + op_null(o); /* repeat */ + op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */ + /* const (rhs): */ + op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL)); + } + } + break; + case OP_OR: + case OP_AND: + case OP_COND_EXPR: + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) + list(kid); + break; + default: + case OP_MATCH: + case OP_QR: + case OP_SUBST: + case OP_NULL: + if (!(o->op_flags & OPf_KIDS)) + break; + if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) { + list(cBINOPo->op_first); + return gen_constant_list(o); + } + listkids(o); + break; + case OP_LIST: + listkids(o); + if (cLISTOPo->op_first->op_type == OP_PUSHMARK) { + op_null(cUNOPo->op_first); /* NULL the pushmark */ + op_null(o); /* NULL the list */ + } + break; + case OP_LEAVE: + case OP_LEAVETRY: + kid = cLISTOPo->op_first; + list(kid); + kid = OpSIBLING(kid); + do_kids: + while (kid) { + OP *sib = OpSIBLING(kid); + if (sib && kid->op_type != OP_LEAVEWHEN) + scalarvoid(kid); + else + list(kid); + kid = sib; + } + PL_curcop = &PL_compiling; + break; + case OP_SCOPE: + case OP_LINESEQ: + kid = cLISTOPo->op_first; + goto do_kids; + } + return o; +} + +static OP * +S_scalarseq(pTHX_ OP *o) +{ + if (o) { + const OPCODE type = o->op_type; + + if (type == OP_LINESEQ || type == OP_SCOPE || + type == OP_LEAVE || type == OP_LEAVETRY) + { + OP *kid, *sib; + for (kid = cLISTOPo->op_first; kid; kid = sib) { + if ((sib = OpSIBLING(kid)) + && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL + || ( sib->op_targ != OP_NEXTSTATE + && sib->op_targ != OP_DBSTATE ))) + { + scalarvoid(kid); + } + } + PL_curcop = &PL_compiling; + } + o->op_flags &= ~OPf_PARENS; + if (PL_hints & HINT_BLOCK_SCOPE) + o->op_flags |= OPf_PARENS; + } + else + o = newOP(OP_STUB, 0); + return o; +} + +STATIC OP * +S_modkids(pTHX_ OP *o, I32 type) +{ + if (o && o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + op_lvalue(kid, type); + } + return o; +} + + +/* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid + * const fields. Also, convert CONST keys to HEK-in-SVs. + * rop is the op that retrieves the hash; + * key_op is the first key + */ + +void +S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) +{ + PADNAME *lexname; + GV **fields; + bool check_fields; + + /* find the padsv corresponding to $lex->{} or @{$lex}{} */ + if (rop) { + if (rop->op_first->op_type == OP_PADSV) + /* @$hash{qw(keys here)} */ + rop = (UNOP*)rop->op_first; + else { + /* @{$hash}{qw(keys here)} */ + if (rop->op_first->op_type == OP_SCOPE + && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV) + { + rop = (UNOP*)cLISTOPx(rop->op_first)->op_last; + } + else + rop = NULL; + } + } + + lexname = NULL; /* just to silence compiler warnings */ + fields = NULL; /* just to silence compiler warnings */ + + check_fields = + rop + && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ), + SvPAD_TYPED(lexname)) + && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE)) + && isGV(*fields) && GvHV(*fields); + + for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) { + SV **svp, *sv; + if (key_op->op_type != OP_CONST) + continue; + svp = cSVOPx_svp(key_op); + + /* make sure it's not a bareword under strict subs */ + if (key_op->op_private & OPpCONST_BARE && + key_op->op_private & OPpCONST_STRICT) + { + no_bareword_allowed((OP*)key_op); + } + + /* Make the CONST have a shared SV */ + if ( !SvIsCOW_shared_hash(sv = *svp) + && SvTYPE(sv) < SVt_PVMG + && 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 %"PNf" of type %"HEKf, + SVfARG(*svp), PNfARG(lexname), + HEKfARG(HvNAME_HEK(PadnameTYPE(lexname)))); + } + } +} + + +/* +=for apidoc finalize_optree + +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. + +=cut +*/ +void +Perl_finalize_optree(pTHX_ OP* o) +{ + PERL_ARGS_ASSERT_FINALIZE_OPTREE; + + ENTER; + SAVEVPTR(PL_curcop); + + finalize_op(o); + + LEAVE; +} + +#ifdef USE_ITHREADS +/* Relocate sv to the pad for thread safety. + * Despite being a "constant", the SV is written to, + * for reference counts, sv_upgrade() etc. */ +PERL_STATIC_INLINE void +S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp) +{ + PADOFFSET ix; + PERL_ARGS_ASSERT_OP_RELOCATE_SV; + if (!*svp) return; + ix = pad_alloc(OP_CONST, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(ix)); + PAD_SETSV(ix, *svp); + /* XXX I don't know how this isn't readonly already. */ + if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix)); + *svp = NULL; + *targp = ix; +} +#endif + + +STATIC void +S_finalize_op(pTHX_ OP* o) +{ + PERL_ARGS_ASSERT_FINALIZE_OP; + + + switch (o->op_type) { + case OP_NEXTSTATE: + case OP_DBSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + break; + case OP_EXEC: + if (OpHAS_SIBLING(o)) { + OP *sib = OpSIBLING(o); + if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) + && ckWARN(WARN_EXEC) + && OpHAS_SIBLING(sib)) + { + const OPCODE type = OpSIBLING(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*)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: + if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { + GV * const gv = cGVOPo_gv; + if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) { + /* XXX could check prototype here instead of just carping */ + SV * const sv = sv_newmortal(); + gv_efullname3(sv, gv, NULL); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), + "%"SVf"() called too early to check prototype", + SVfARG(sv)); + } + } + break; + + case OP_CONST: + if (cSVOPo->op_private & OPpCONST_STRICT) + no_bareword_allowed(o); + /* FALLTHROUGH */ +#ifdef USE_ITHREADS + case OP_HINTSEVAL: + op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); +#endif + break; + +#ifdef USE_ITHREADS + /* Relocate all the METHOP's SVs to the pad for thread safety. */ + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: + case OP_METHOD_REDIR_SUPER: + op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ); + break; +#endif + + case OP_HELEM: { + UNOP *rop; + SVOP *key_op; + OP *kid; + + if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST) + break; + + rop = (UNOP*)((BINOP*)o)->op_first; + + goto check_keys; + + case OP_HSLICE: + S_scalar_slice_warning(aTHX_ o); + /* FALLTHROUGH */ + + case OP_KVHSLICE: + kid = OpSIBLING(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_op = (SVOP*)(kid->op_type == OP_CONST + ? kid + : OpSIBLING(kLISTOP->op_first)); + + rop = (UNOP*)((LISTOP*)o)->op_last; + + check_keys: + if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV) + rop = NULL; + S_check_hash_fields_and_hekify(aTHX_ rop, key_op); + break; + } + case OP_ASLICE: + S_scalar_slice_warning(aTHX_ o); + break; + + case OP_SUBST: { + if (cPMOPo->op_pmreplrootu.op_pmreplroot) + finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); + break; + } + default: + break; + } + + if (o->op_flags & OPf_KIDS) { + OP *kid; + +#ifdef DEBUGGING + /* check that op_last points to the last sibling, and that + * the last op_sibling/op_sibparent 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_UNOP_AUX + || family == OA_LOGOP + || family == OA_BASEOP_OR_UNOP + || family == OA_FILESTATOP + || family == OA_LOOPEXOP + || family == OA_METHOP + /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ + || type == OP_SASSIGN + || type == OP_CUSTOM + || type == OP_NULL /* new_logop does this */ + ); + + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { +# ifdef PERL_OP_PARENT + if (!OpHAS_SIBLING(kid)) { + if (has_last) + assert(kid == cLISTOPo->op_last); + assert(kid->op_sibparent == o); + } +# else + if (has_last && !OpHAS_SIBLING(kid)) + assert(kid == cLISTOPo->op_last); +# endif + } +#endif + + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) + finalize_op(kid); + } +} + +/* +=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type + +Propagate lvalue ("modifiable") context to an op and its children. +I<type> represents the context type, roughly based on the type of op that +would do the modifying, although C<local()> is represented by OP_NULL, +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 +called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN. + +It also flags things that need to behave specially in an lvalue context, +such as C<$$x = 5> which might have to vivify a reference in C<$x>. + +=cut +*/ + +static void +S_mark_padname_lvalue(pTHX_ PADNAME *pn) +{ + CV *cv = PL_compcv; + PadnameLVALUE_on(pn); + while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { + cv = CvOUTSIDE(cv); + /* RT #127786: cv can be NULL due to an eval within the DB package + * called from an anon sub - anon subs don't have CvOUTSIDE() set + * unless they contain an eval, but calling eval within DB + * pretends the eval was done in the caller's scope. + */ + if (!cv) + break; + assert(CvPADLIST(cv)); + pn = + PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; + assert(PadnameLEN(pn)); + PadnameLVALUE_on(pn); + } +} + +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; +} + +static void +S_lvref(pTHX_ OP *o, I32 type) +{ + dVAR; + OP *kid; + switch (o->op_type) { + case OP_COND_EXPR: + for (kid = OpSIBLING(cUNOPo->op_first); kid; + kid = OpSIBLING(kid)) + S_lvref(aTHX_ kid, type); + /* FALLTHROUGH */ + case OP_PUSHMARK: + return; + case OP_RV2AV: + if (cUNOPo->op_first->op_type != OP_GV) goto badref; + o->op_flags |= OPf_STACKED; + if (o->op_flags & OPf_PARENS) { + if (o->op_private & OPpLVAL_INTRO) { + yyerror(Perl_form(aTHX_ "Can't modify reference to " + "localized parenthesized array in list assignment")); + return; + } + slurpy: + OpTYPE_set(o, OP_LVAVREF); + o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; + o->op_flags |= OPf_MOD|OPf_REF; + return; + } + o->op_private |= OPpLVREF_AV; + goto checkgv; + case OP_RV2CV: + kid = cUNOPo->op_first; + if (kid->op_type == OP_NULL) + kid = cUNOPx(OpSIBLING(kUNOP->op_first)) + ->op_first; + o->op_private = OPpLVREF_CV; + if (kid->op_type == OP_GV) + o->op_flags |= OPf_STACKED; + else if (kid->op_type == OP_PADCV) { + o->op_targ = kid->op_targ; + kid->op_targ = 0; + op_free(cUNOPo->op_first); + cUNOPo->op_first = NULL; + o->op_flags &=~ OPf_KIDS; + } + else goto badref; + break; + case OP_RV2HV: + if (o->op_flags & OPf_PARENS) { + parenhash: + yyerror(Perl_form(aTHX_ "Can't modify reference to " + "parenthesized hash in list assignment")); + return; + } + o->op_private |= OPpLVREF_HV; + /* FALLTHROUGH */ + case OP_RV2SV: + checkgv: + if (cUNOPo->op_first->op_type != OP_GV) goto badref; + o->op_flags |= OPf_STACKED; + break; + case OP_PADHV: + if (o->op_flags & OPf_PARENS) goto parenhash; + o->op_private |= OPpLVREF_HV; + /* FALLTHROUGH */ + case OP_PADSV: + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; + case OP_PADAV: + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + if (o->op_flags & OPf_PARENS) goto slurpy; + o->op_private |= OPpLVREF_AV; + break; + case OP_AELEM: + case OP_HELEM: + o->op_private |= OPpLVREF_ELEM; + o->op_flags |= OPf_STACKED; + break; + case OP_ASLICE: + case OP_HSLICE: + OpTYPE_set(o, OP_LVREFSLICE); + o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM; + return; + case OP_NULL: + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto badref; + else if (!(o->op_flags & OPf_KIDS)) + return; + if (o->op_targ != OP_LIST) { + S_lvref(aTHX_ cBINOPo->op_first, type); + return; + } + /* FALLTHROUGH */ + case OP_LIST: + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) { + assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID); + S_lvref(aTHX_ kid, type); + } + return; + case OP_STUB: + if (o->op_flags & OPf_PARENS) + return; + /* FALLTHROUGH */ + default: + badref: + /* diag_listed_as: Can't modify reference to %s in %s assignment */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s", + o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL + ? "do block" + : OP_DESC(o), + PL_op_desc[type])); + } + OpTYPE_set(o, OP_LVREF); + o->op_private &= + OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE; + if (type == OP_ENTERLOOP) + o->op_private |= OPpLVREF_ITER; +} + +OP * +Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) +{ + dVAR; + OP *kid; + /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ + int localize = -1; + + if (!o || (PL_parser && PL_parser->error_count)) + return o; + + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { + return o; + } + + assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID ); + + if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; + + switch (o->op_type) { + case OP_UNDEF: + PL_modcount++; + return o; + case OP_STUB: + 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)) { + OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ + assert(cUNOPo->op_first->op_type == OP_NULL); + op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ + break; + } + else { /* lvalue subroutine call */ + o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (type == OP_GREPSTART || type == OP_ENTERSUB + || type == OP_REFGEN || type == OP_LEAVESUBLV) { + /* Potential lvalue context: */ + o->op_private |= OPpENTERSUB_INARGS; + break; + } + 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) + Perl_croak(aTHX_ + "panic: unexpected lvalue entersub " + "args: type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); + kid = kLISTOP->op_first; + } + while (OpHAS_SIBLING(kid)) + kid = OpSIBLING(kid); + if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { + break; /* Postpone until runtime */ + } + + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) + kid = kUNOP->op_first; + if (kid->op_type == OP_NULL) + Perl_croak(aTHX_ + "Unexpected constant lvalue entersub " + "entry via type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); + if (kid->op_type != OP_GV) { + break; + } + + 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; + } + } + /* FALLTHROUGH */ + default: + nomod: + if (flags & OP_LVALUE_NO_CROAK) return NULL; + /* grep, foreach, subcalls, refgen */ + if (type == OP_GREPSTART || type == OP_ENTERSUB + || type == OP_REFGEN || type == OP_LEAVESUBLV) + break; + yyerror(Perl_form(aTHX_ "Can't modify %s in %s", + (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) + ? "do block" + : (o->op_type == OP_ENTERSUB + ? "non-lvalue subroutine call" + : OP_DESC(o))), + type ? PL_op_desc[type] : "local")); + return o; + + case OP_PREINC: + case OP_PREDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_ADD: + case OP_SUBTRACT: + case OP_CONCAT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + if (!(o->op_flags & OPf_STACKED)) + goto nomod; + PL_modcount++; + break; + + case OP_REPEAT: + if (o->op_flags & OPf_STACKED) { + PL_modcount++; + break; + } + if (!(o->op_private & OPpREPEAT_DOLIST)) + goto nomod; + else { + const I32 mods = PL_modcount; + modkids(cBINOPo->op_first, type); + if (type != OP_AASSIGN) + goto nomod; + kid = cBINOPo->op_last; + if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) { + const IV iv = SvIV(kSVOP_sv); + if (PL_modcount != RETURN_UNLIMITED_NUMBER) + PL_modcount = + mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv); + } + else + PL_modcount = RETURN_UNLIMITED_NUMBER; + } + break; + + case OP_COND_EXPR: + localize = 1; + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid)) + op_lvalue(kid, type); + break; + + case OP_RV2AV: + case OP_RV2HV: + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { + PL_modcount = RETURN_UNLIMITED_NUMBER; + return o; /* Treat \(@foo) like ordinary list. */ + } + /* FALLTHROUGH */ + case OP_RV2GV: + if (scalar_mod_type(o, type)) + goto nomod; + ref(cUNOPo->op_first, o->op_type); + /* FALLTHROUGH */ + case OP_ASLICE: + case OP_HSLICE: + localize = 1; + /* FALLTHROUGH */ + case OP_AASSIGN: + /* 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; + /* 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) + o->op_private |= OPpMAYBE_LVSUB; + PL_modcount++; + break; + case OP_RV2SV: + ref(cUNOPo->op_first, o->op_type); + localize = 1; + /* FALLTHROUGH */ + case OP_GV: + PL_hints |= HINT_BLOCK_SCOPE; + /* FALLTHROUGH */ + case OP_SASSIGN: + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: + PL_modcount++; + break; + + case OP_AELEMFAST: + case OP_AELEMFAST_LEX: + localize = -1; + PL_modcount++; + break; + + case OP_PADAV: + case OP_PADHV: + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) + return o; /* Treat \(@foo) like ordinary list. */ + if (scalar_mod_type(o, type)) + goto nomod; + if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR + && type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALLTHROUGH */ + case OP_PADSV: + PL_modcount++; + if (!type) /* local() */ + Perl_croak(aTHX_ "Can't localize lexical variable %"PNf, + PNfARG(PAD_COMPNAME(o->op_targ))); + if (!(o->op_private & OPpLVAL_INTRO) + || ( type != OP_SASSIGN && type != OP_AASSIGN + && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) )) + S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ)); + break; + + case OP_PUSHMARK: + localize = 0; + break; + + case OP_KEYS: + case OP_RKEYS: + if (type != OP_SASSIGN && type != OP_LEAVESUBLV) + goto nomod; + goto lvalue_func; + case OP_SUBSTR: + if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ + goto nomod; + /* 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(OpSIBLING(cBINOPo->op_first), type); + break; + + case OP_AELEM: + case OP_HELEM: + ref(cBINOPo->op_first, o->op_type); + if (type == OP_ENTERSUB && + !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) + o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + localize = 1; + PL_modcount++; + break; + + case OP_LEAVE: + case OP_LEAVELOOP: + o->op_private |= OPpLVALUE; + /* FALLTHROUGH */ + case OP_SCOPE: + case OP_ENTER: + case OP_LINESEQ: + localize = 0; + if (o->op_flags & OPf_KIDS) + op_lvalue(cLISTOPo->op_last, type); + break; + + case OP_NULL: + localize = 0; + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto nomod; + else if (!(o->op_flags & OPf_KIDS)) + break; + if (o->op_targ != OP_LIST) { + op_lvalue(cBINOPo->op_first, type); + break; + } + /* FALLTHROUGH */ + case OP_LIST: + localize = 0; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(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 ) + op_lvalue(kid, type); + break; + + 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(OpSIBLING(cLOGOPo->op_first)->op_type)) + op_lvalue(OpSIBLING(cLOGOPo->op_first), type); + goto nomod; + + case OP_SREFGEN: + if (type != OP_AASSIGN && type != OP_SASSIGN + && type != OP_ENTERLOOP) + goto nomod; + /* Don’t bother applying lvalue context to the ex-list. */ + kid = cUNOPx(cUNOPo->op_first)->op_first; + assert (!OpHAS_SIBLING(kid)); + goto kid_2lvref; + case OP_REFGEN: + if (type != OP_AASSIGN) goto nomod; + kid = cUNOPo->op_first; + kid_2lvref: + { + const U8 ec = PL_parser ? PL_parser->error_count : 0; + S_lvref(aTHX_ kid, type); + if (!PL_parser || PL_parser->error_count == ec) { + if (!FEATURE_REFALIASING_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental aliasing via reference not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__REFALIASING), + "Aliasing via reference is experimental"); + } + } + if (o->op_type == OP_REFGEN) + op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */ + op_null(o); + return o; + + case OP_SPLIT: + kid = cLISTOPo->op_first; + if (kid && kid->op_type == OP_PUSHRE && + ( kid->op_targ + || o->op_flags & OPf_STACKED +#ifdef USE_ITHREADS + || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff +#else + || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv +#endif + )) { + /* This is actually @array = split. */ + PL_modcount = RETURN_UNLIMITED_NUMBER; + break; + } + goto nomod; + + case OP_SCALAR: + op_lvalue(cUNOPo->op_first, OP_ENTERSUB); + goto nomod; + } + + /* [20011101.069] File test operators interpret OPf_REF to mean that + their argument is a filehandle; thus \stat(".") should not set + it. AMS 20011102 */ + if (type == OP_REFGEN && + PL_check[o->op_type] == Perl_ck_ftst) + return o; + + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; + + if (type == OP_AASSIGN || type == OP_SASSIGN) + o->op_flags |= OPf_SPECIAL|OPf_REF; + else if (!type) { /* local() */ + switch (localize) { + case 1: + o->op_private |= OPpLVAL_INTRO; + o->op_flags &= ~OPf_SPECIAL; + PL_hints |= HINT_BLOCK_SCOPE; + break; + case 0: + break; + case -1: + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless localization of %s", OP_DESC(o)); + } + } + else if (type != OP_GREPSTART && type != OP_ENTERSUB + && type != OP_LEAVESUBLV) + o->op_flags |= OPf_REF; + return o; +} + +STATIC bool +S_scalar_mod_type(const OP *o, I32 type) +{ + switch (type) { + case OP_POS: + case OP_SASSIGN: + if (o && o->op_type == OP_RV2GV) + return FALSE; + /* FALLTHROUGH */ + case OP_PREINC: + case OP_PREDEC: + case OP_POSTINC: + case OP_POSTDEC: + case OP_I_PREINC: + case OP_I_PREDEC: + case OP_I_POSTINC: + case OP_I_POSTDEC: + case OP_POW: + case OP_MULTIPLY: + case OP_DIVIDE: + case OP_MODULO: + case OP_REPEAT: + case OP_ADD: + case OP_SUBTRACT: + case OP_I_MULTIPLY: + case OP_I_DIVIDE: + case OP_I_MODULO: + case OP_I_ADD: + case OP_I_SUBTRACT: + case OP_LEFT_SHIFT: + case OP_RIGHT_SHIFT: + case OP_BIT_AND: + case OP_BIT_XOR: + case OP_BIT_OR: + case OP_CONCAT: + case OP_SUBST: + case OP_TRANS: + case OP_TRANSR: + case OP_READ: + case OP_SYSREAD: + case OP_RECV: + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: + return TRUE; + default: + return FALSE; + } +} + +STATIC bool +S_is_handle_constructor(const OP *o, I32 numargs) +{ + PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; + + switch (o->op_type) { + case OP_PIPE_OP: + case OP_SOCKPAIR: + if (numargs == 2) + return TRUE; + /* FALLTHROUGH */ + case OP_SYSOPEN: + case OP_OPEN: + case OP_SELECT: /* XXX c.f. SelectSaver.pm */ + case OP_SOCKET: + case OP_OPEN_DIR: + case OP_ACCEPT: + if (numargs == 1) + return TRUE; + /* FALLTHROUGH */ + default: + return FALSE; + } +} + +static OP * +S_refkids(pTHX_ OP *o, I32 type) +{ + if (o && o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + ref(kid, type); + } + return o; +} + +OP * +Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) +{ + dVAR; + OP *kid; + + PERL_ARGS_ASSERT_DOREF; + + if (PL_parser && PL_parser->error_count) + return o; + + switch (o->op_type) { + case OP_ENTERSUB: + if ((type == OP_EXISTS || type == OP_DEFINED) && + !(o->op_flags & OPf_STACKED)) { + OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */ + assert(cUNOPo->op_first->op_type == OP_NULL); + op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ + o->op_flags |= OPf_SPECIAL; + } + else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; + } + + break; + + case OP_COND_EXPR: + for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(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); + /* FALLTHROUGH */ + case OP_PADSV: + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; + } + break; + + case OP_RV2AV: + case OP_RV2HV: + if (set_op_ref) + o->op_flags |= OPf_REF; + /* FALLTHROUGH */ + case OP_RV2GV: + if (type == OP_DEFINED) + o->op_flags |= OPf_SPECIAL; /* don't create GV */ + doref(cUNOPo->op_first, o->op_type, set_op_ref); + break; + + case OP_PADAV: + case OP_PADHV: + if (set_op_ref) + o->op_flags |= OPf_REF; + break; + + case OP_SCALAR: + case OP_NULL: + if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED) + break; + doref(cBINOPo->op_first, type, set_op_ref); + break; + case OP_AELEM: + case OP_HELEM: + doref(cBINOPo->op_first, o->op_type, set_op_ref); + if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { + o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV + : type == OP_RV2HV ? OPpDEREF_HV + : OPpDEREF_SV); + o->op_flags |= OPf_MOD; + } + break; + + case OP_SCOPE: + case OP_LEAVE: + set_op_ref = FALSE; + /* FALLTHROUGH */ + case OP_ENTER: + case OP_LIST: + if (!(o->op_flags & OPf_KIDS)) + break; + doref(cLISTOPo->op_last, type, set_op_ref); + break; + default: + break; + } + return scalar(o); + +} + +STATIC OP * +S_dup_attrlist(pTHX_ OP *o) +{ + OP *rop; + + PERL_ARGS_ASSERT_DUP_ATTRLIST; + + /* An attrlist is either a simple OP_CONST or an OP_LIST with kids, + * where the first kid is OP_PUSHMARK and the remaining ones + * are OP_CONST. We need to push the OP_CONST values. + */ + if (o->op_type == OP_CONST) + rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); + else { + assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); + rop = NULL; + for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) { + if (o->op_type == OP_CONST) + rop = op_append_elem(OP_LIST, rop, + newSVOP(OP_CONST, o->op_flags, + SvREFCNT_inc_NN(cSVOPo->op_sv))); + } + } + return rop; +} + +STATIC void +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) +{ + SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + + PERL_ARGS_ASSERT_APPLY_ATTRS; + + /* fake up C<use attributes $pkg,$rv,@attrs> */ + +#define ATTRSMODULE "attributes" +#define ATTRSMODULE_PM "attributes.pm" + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvs(ATTRSMODULE), + NULL, + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); +} + +STATIC void +S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) +{ + OP *pack, *imop, *arg; + SV *meth, *stashsv, **svp; + + PERL_ARGS_ASSERT_APPLY_ATTRS_MY; + + if (!attrs) + return; + + assert(target->op_type == OP_PADSV || + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); + + /* Ensure that attributes.pm is loaded. */ + /* Don't force the C<use> if we don't need it. */ + svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); + if (svp && *svp != &PL_sv_undef) + NOOP; /* already in %INC */ + else + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs(ATTRSMODULE), NULL); + + /* Need package name for method call. */ + pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); + + /* Build up the real arg-list. */ + stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; + + arg = newOP(OP_PADSV, 0); + arg->op_targ = target->op_targ; + arg = op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + op_prepend_elem(OP_LIST, + newUNOP(OP_REFGEN, 0, + arg), + dup_attrlist(attrs))); + + /* Fake up a method call to import */ + meth = newSVpvs_share("import"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); + + /* Combine the ops. */ + *imopsp = op_append_elem(OP_LIST, *imopsp, imop); +} + +/* +=notfor apidoc apply_attrs_string + +Attempts to apply a list of attributes specified by the C<attrstr> and +C<len> arguments to the subroutine identified by the C<cv> argument which +is expected to be associated with the package identified by the C<stashpv> +argument (see L<attributes>). It gets this wrong, though, in that it +does not correctly identify the boundaries of the individual attribute +specifications within C<attrstr>. This is not really intended for the +public API, but has to be listed here for systems such as AIX which +need an explicit export list for symbols. (It's called from XS code +in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it +to respect attribute syntax properly would be welcome. + +=cut +*/ + +void +Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, + const char *attrstr, STRLEN len) +{ + OP *attrs = NULL; + + PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + const char * const sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = op_append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvs(ATTRSMODULE), + NULL, op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(MUTABLE_SV(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 = OpSIBLING(lasto); o; o = OpSIBLING(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 (!OpHAS_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) +{ + I32 type; + const bool stately = PL_parser && PL_parser->in_my == KEY_state; + + PERL_ARGS_ASSERT_MY_KID; + + if (!o || (PL_parser && PL_parser->error_count)) + return o; + + type = o->op_type; + + if (type == OP_LIST) { + OP *kid; + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + my_kid(kid, attrs, imopsp); + return o; + } else if (type == OP_UNDEF || type == OP_STUB) { + return o; + } else if (type == OP_RV2SV || /* "our" declaration */ + type == OP_RV2AV || + type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + 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), + (type == OP_RV2SV ? GvSV(gv) : + type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : + type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), + attrs); + } + o->op_private |= OPpOUR_INTRO; + return o; + } + else if (type != OP_PADSV && + type != OP_PADAV && + type != OP_PADHV && + type != OP_PUSHMARK) + { + 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; + + /* check for C<my Dog $spot> when deciding package */ + stash = PAD_COMPNAME_TYPE(o->op_targ); + if (!stash) + stash = PL_curstash; + apply_attrs_my(stash, o, attrs, imopsp); + } + o->op_flags |= OPf_MOD; + o->op_private |= OPpLVAL_INTRO; + if (stately) + o->op_private |= OPpPAD_STATE; + return o; +} + +OP * +Perl_my_attrs(pTHX_ OP *o, OP *attrs) +{ + OP *rops; + int maybe_scalar = 0; + + PERL_ARGS_ASSERT_MY_ATTRS; + +/* [perl #17376]: this appears to be premature, and results in code such as + C< our(%x); > executing in list mode rather than void mode */ +#if 0 + if (o->op_flags & OPf_PARENS) + list(o); + else + maybe_scalar = 1; +#else + maybe_scalar = 1; +#endif + if (attrs) + SAVEFREEOP(attrs); + rops = NULL; + o = my_kid(o, attrs, &rops); + if (rops) { + if (maybe_scalar && o->op_type == OP_PADSV) { + o = scalar(op_append_list(OP_LIST, rops, o)); + o->op_private |= OPpLVAL_INTRO; + } + else { + /* The listop in rops might have a pushmark at the beginning, + which will mess up list assignment. */ + LISTOP * const lrops = (LISTOP *)rops; /* for brevity */ + if (rops->op_type == OP_LIST && + lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) + { + OP * const pushmark = lrops->op_first; + /* excise pushmark */ + op_sibling_splice(rops, NULL, 1, NULL); + op_free(pushmark); + } + o = op_append_list(OP_LIST, o, rops); + } + } + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; + return o; +} + +OP * +Perl_sawparens(pTHX_ OP *o) +{ + PERL_UNUSED_CONTEXT; + if (o) + o->op_flags |= OPf_PARENS; + return o; +} + +OP * +Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) +{ + OP *o; + bool ismatchop = 0; + const OPCODE ltype = left->op_type; + const OPCODE rtype = right->op_type; + + PERL_ARGS_ASSERT_BIND_MATCH; + + if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV + || ltype == OP_PADHV) && ckWARN(WARN_MISC)) + { + const char * const desc + = PL_op_desc[( + rtype == OP_SUBST || rtype == OP_TRANS + || rtype == OP_TRANSR + ) + ? (int)rtype : OP_MATCH]; + const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; + SV * const name = + S_op_varname(aTHX_ left); + if (name) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Applying %s to %"SVf" will act on scalar(%"SVf")", + desc, SVfARG(name), SVfARG(name)); + else { + const char * const sample = (isary + ? "@array" : "%hash"); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Applying %s to %s will act on scalar(%s)", + desc, sample, sample); + } + } + + if (rtype == OP_CONST && + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) + { + no_bareword_allowed(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 || + rtype == OP_SUBST || + rtype == OP_TRANS || rtype == OP_TRANSR) + && !(right->op_flags & OPf_SPECIAL); + if (ismatchop && right->op_private & OPpTARGET_MY) { + right->op_targ = 0; + right->op_private &= ~OPpTARGET_MY; + } + if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) { + if (left->op_type == OP_PADSV + && !(left->op_private & OPpLVAL_INTRO)) + { + right->op_targ = left->op_targ; + op_free(left); + o = right; + } + else { + right->op_flags |= OPf_STACKED; + if (rtype != OP_MATCH && rtype != OP_TRANSR && + ! (rtype == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL) && + ! (rtype == OP_SUBST && + (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT))) + left = op_lvalue(left, rtype); + if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR) + o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); + else + o = op_prepend_elem(rtype, scalar(left), right); + } + if (type == OP_NOT) + return newUNOP(OP_NOT, 0, scalar(o)); + return o; + } + else + return bind_match(type, left, + pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0)); +} + +OP * +Perl_invert(pTHX_ OP *o) +{ + if (!o) + return NULL; + return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); +} + +/* +=for apidoc Amx|OP *|op_scope|OP *o + +Wraps up an op tree with some additional ops so that at runtime a dynamic +scope will be created. The original ops run in the new dynamic scope, +and then, provided that they exit normally, the scope will be unwound. +The additional ops used to create and unwind the dynamic scope will +normally be an C<enter>/C<leave> pair, but a C<scope> op may be used +instead if the ops are simple enough to not need the full dynamic scope +structure. + +=cut +*/ + +OP * +Perl_op_scope(pTHX_ OP *o) +{ + dVAR; + if (o) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); + OpTYPE_set(o, OP_LEAVE); + } + else if (o->op_type == OP_LINESEQ) { + OP *kid; + OpTYPE_set(o, OP_SCOPE); + kid = ((LISTOP*)o)->op_first; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + op_null(kid); + + /* The following deals with things like 'do {1 for 1}' */ + kid = OpSIBLING(kid); + if (kid && + (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) + op_null(kid); + } + } + else + o = newLISTOP(OP_SCOPE, 0, o, NULL); + } + return o; +} + +OP * +Perl_op_unscope(pTHX_ OP *o) +{ + if (o && o->op_type == OP_LINESEQ) { + OP *kid = cLISTOPo->op_first; + for(; kid; kid = OpSIBLING(kid)) + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + op_null(kid); + } + return o; +} + +/* +=for apidoc Am|int|block_start|int full + +Handles compile-time scope entry. +Arranges for hints to be restored on block +exit and also handles pad sequence numbers to make lexical variables scope +right. Returns a savestack index for use with C<block_end>. + +=cut +*/ + +int +Perl_block_start(pTHX_ int full) +{ + const int retval = PL_savestack_ix; + + PL_compiling.cop_seq = PL_cop_seqmax; + COP_SEQMAX_INC; + pad_block_start(full); + SAVEHINTS(); + PL_hints &= ~HINT_BLOCK_SCOPE; + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); + SAVEI32(PL_compiling.cop_seq); + PL_compiling.cop_seq = 0; + + CALL_BLOCK_HOOKS(bhk_start, full); + + return retval; +} + +/* +=for apidoc Am|OP *|block_end|I32 floor|OP *seq + +Handles compile-time scope exit. I<floor> +is the savestack index returned by +C<block_start>, and I<seq> is the body of the block. Returns the block, +possibly modified. + +=cut +*/ + +OP* +Perl_block_end(pTHX_ I32 floor, OP *seq) +{ + const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; + OP* retval = scalarseq(seq); + OP *o; + + /* XXX Is the null PL_parser check necessary here? */ + assert(PL_parser); /* Let’s find out under debugging builds. */ + if (PL_parser && PL_parser->parsed_sub) { + o = newSTATEOP(0, NULL, NULL); + op_null(o); + retval = op_append_elem(OP_LINESEQ, retval, o); + } + + CALL_BLOCK_HOOKS(bhk_pre_end, &retval); + + LEAVE_SCOPE(floor); + if (needblockscope) + PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ + o = pad_leavemy(); + + if (o) { + /* pad_leavemy has created a sequence of introcv ops for all my + subs declared in the block. We have to replicate that list with + clonecv ops, to deal with this situation: + + sub { + my sub s1; + my sub s2; + sub s1 { state sub foo { \&s2 } } + }->() + + Originally, I was going to have introcv clone the CV and turn + off the stale flag. Since &s1 is declared before &s2, the + introcv op for &s1 is executed (on sub entry) before the one for + &s2. But the &foo sub inside &s1 (which is cloned when &s1 is + cloned, since it is a state sub) closes over &s2 and expects + to see it in its outer CV’s pad. If the introcv op clones &s1, + then &s2 is still marked stale. Since &s1 is not active, and + &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia- + ble will not stay shared’ warning. Because it is the same stub + that will be used when the introcv op for &s2 is executed, clos- + ing over it is safe. Hence, we have to turn off the stale flag + on all lexical subs in the block before we clone any of them. + Hence, having introcv clone the sub cannot work. So we create a + list of ops like this: + + lineseq + | + +-- introcv + | + +-- introcv + | + +-- introcv + | + . + . + . + | + +-- clonecv + | + +-- clonecv + | + +-- clonecv + | + . + . + . + */ + 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 = OpSIBLING(kid)) { + OP *newkid = newOP(OP_CLONECV, 0); + newkid->op_targ = kid->op_targ; + o = op_append_elem(OP_LINESEQ, o, newkid); + if (kid == last) break; + } + retval = op_prepend_elem(OP_LINESEQ, o, retval); + } + + CALL_BLOCK_HOOKS(bhk_post_end, &retval); + + return retval; +} + +/* +=head1 Compile-time scope hooks + +=for apidoc Aox||blockhook_register + +Register a set of hooks to be called when the Perl lexical scope changes +at compile time. See L<perlguts/"Compile-time scope hooks">. + +=cut +*/ + +void +Perl_blockhook_register(pTHX_ BHK *hk) +{ + PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER; + + Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk))); +} + +void +Perl_newPROG(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_NEWPROG; + + if (PL_in_eval) { + PERL_CONTEXT *cx; + I32 i; + if (PL_eval_root) + return; + PL_eval_root = newUNOP(OP_LEAVEEVAL, + ((PL_in_eval & EVAL_KEEPERR) + ? OPf_SPECIAL : 0), o); + + cx = &cxstack[cxstack_ix]; + assert(CxTYPE(cx) == CXt_EVAL); + + if ((cx->blk_gimme & G_WANT) == G_VOID) + scalarvoid(PL_eval_root); + else if ((cx->blk_gimme & G_WANT) == G_ARRAY) + list(PL_eval_root); + else + scalar(PL_eval_root); + + PL_eval_start = op_linklist(PL_eval_root); + PL_eval_root->op_private |= OPpREFCOUNTED; + OpREFCNT_set(PL_eval_root, 1); + PL_eval_root->op_next = 0; + i = PL_savestack_ix; + SAVEFREEOP(o); + ENTER; + CALL_PEEP(PL_eval_start); + finalize_optree(PL_eval_root); + S_prune_chain_head(&PL_eval_start); + LEAVE; + PL_savestack_ix = i; + } + else { + if (o->op_type == OP_STUB) { + /* This block is entered if nothing is compiled for the main + program. This will be the case for an genuinely empty main + program, or one which only has BEGIN blocks etc, so already + run and freed. + + Historically (5.000) the guard above was !o. However, commit + f8a08f7b8bd67b28 (Jun 2001), integrated to blead as + c71fccf11fde0068, changed perly.y so that newPROG() is now + called with the output of block_end(), which returns a new + OP_STUB for the case of an empty optree. ByteLoader (and + maybe other things) also take this path, because they set up + PL_main_start and PL_main_root directly, without generating an + optree. + + If the parsing the main program aborts (due to parse errors, + or due to BEGIN or similar calling exit), then newPROG() + isn't even called, and hence this code path and its cleanups + are skipped. This shouldn't make a make a difference: + * a non-zero return from perl_parse is a failure, and + perl_destruct() should be called immediately. + * however, if exit(0) is called during the parse, then + perl_parse() returns 0, and perl_run() is called. As + PL_main_start will be NULL, perl_run() will return + promptly, and the exit code will remain 0. + */ + + PL_comppad_name = 0; + PL_compcv = 0; + S_op_destroy(aTHX_ o); + return; + } + PL_main_root = op_scope(sawparens(scalarvoid(o))); + PL_curcop = &PL_compiling; + PL_main_start = LINKLIST(PL_main_root); + PL_main_root->op_private |= OPpREFCOUNTED; + OpREFCNT_set(PL_main_root, 1); + 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; + + /* Register with debugger */ + if (PERLDB_INTER) { + CV * const cv = get_cvs("DB::postponed", 0); + if (cv) { + dSP; + PUSHMARK(SP); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); + PUTBACK; + call_sv(MUTABLE_SV(cv), G_DISCARD); + } + } + } +} + +OP * +Perl_localize(pTHX_ OP *o, I32 lex) +{ + PERL_ARGS_ASSERT_LOCALIZE; + + if (o->op_flags & OPf_PARENS) +/* [perl #17376]: this appears to be premature, and results in code such as + C< our(%x); > executing in list mode rather than void mode */ +#if 0 + list(o); +#else + NOOP; +#endif + else { + if ( PL_parser->bufptr > PL_parser->oldbufptr + && PL_parser->bufptr[-1] == ',' + && ckWARN(WARN_PARENTHESIS)) + { + char *s = PL_parser->bufptr; + bool sigil = FALSE; + + /* some heuristics to detect a potential error */ + while (*s && (strchr(", \t\n", *s))) + s++; + + while (1) { + if (*s && strchr("@$%*", *s) && *++s + && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { + s++; + sigil = TRUE; + while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) + s++; + while (*s && (strchr(", \t\n", *s))) + s++; + } + else + break; + } + if (sigil && (*s == ';' || *s == '=')) { + Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), + "Parentheses missing around \"%s\" list", + lex + ? (PL_parser->in_my == KEY_our + ? "our" + : PL_parser->in_my == KEY_state + ? "state" + : "my") + : "local"); + } + } + } + if (lex) + o = my(o); + else + o = op_lvalue(o, OP_NULL); /* a bit kludgey */ + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; + return o; +} + +OP * +Perl_jmaybe(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_JMAYBE; + + if (o->op_type == OP_LIST) { + OP * const o2 + = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV))); + o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o)); + } + return o; +} + +PERL_STATIC_INLINE OP * +S_op_std_init(pTHX_ OP *o) +{ + I32 type = o->op_type; + + PERL_ARGS_ASSERT_OP_STD_INIT; + + if (PL_opargs[type] & OA_RETSCALAR) + scalar(o); + if (PL_opargs[type] & OA_TARGET && !o->op_targ) + o->op_targ = pad_alloc(type, SVs_PADTMP); + + return o; +} + +PERL_STATIC_INLINE OP * +S_op_integerize(pTHX_ OP *o) +{ + I32 type = o->op_type; + + PERL_ARGS_ASSERT_OP_INTEGERIZE; + + /* integerize op. */ + if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) + { + dVAR; + o->op_ppaddr = PL_ppaddr[++(o->op_type)]; + } + + if (type == OP_NEGATE) + /* XXX might want a ck_negate() for this */ + cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; + + return o; +} + +static OP * +S_fold_constants(pTHX_ OP *o) +{ + dVAR; + OP * VOL curop; + OP *newop; + VOL I32 type = o->op_type; + bool is_stringify; + SV * VOL sv = NULL; + int ret = 0; + I32 oldscope; + OP *old_next; + SV * const oldwarnhook = PL_warnhook; + SV * const olddiehook = PL_diehook; + COP not_compiling; + U8 oldwarn = PL_dowarn; + dJMPENV; + + PERL_ARGS_ASSERT_FOLD_CONSTANTS; + + if (!(PL_opargs[type] & OA_FOLDCONST)) + goto nope; + + switch (type) { + case OP_UCFIRST: + case OP_LCFIRST: + 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? */ +#ifdef USE_LOCALE_NUMERIC + if (IN_LC_COMPILETIME(LC_NUMERIC)) + goto nope; +#endif + break; + case OP_PACK: + if (!OpHAS_SIBLING(cLISTOPo->op_first) + || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST) + goto nope; + { + SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first)); + if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; + { + const char *s = SvPVX_const(sv); + while (s < SvEND(sv)) { + if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; + s++; + } + } + } + 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) + goto nope; /* Don't try to run w/ errors */ + + for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { + const OPCODE type = curop->op_type; + if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) && + type != OP_LIST && + type != OP_SCALAR && + type != OP_NULL && + type != OP_PUSHMARK) + { + goto nope; + } + } + + curop = LINKLIST(o); + old_next = o->op_next; + o->op_next = 0; + PL_op = curop; + + oldscope = PL_scopestack_ix; + create_eval_scope(G_FAKINGEVAL); + + /* Verify that we don't need to save it: */ + assert(PL_curcop == &PL_compiling); + StructCopy(&PL_compiling, ¬_compiling, COP); + PL_curcop = ¬_compiling; + /* The above ensures that we run with all the correct hints of the + currently compiling COP, but that IN_PERL_RUNTIME is true. */ + assert(IN_PERL_RUNTIME); + PL_warnhook = PERL_WARNHOOK_FATAL; + PL_diehook = NULL; + JMPENV_PUSH(ret); + + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + + switch (ret) { + case 0: + CALLRUNOPS(aTHX); + sv = *(PL_stack_sp--); + if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ + pad_swipe(o->op_targ, FALSE); + } + else if (SvTEMP(sv)) { /* grab mortal temp? */ + SvREFCNT_inc_simple_void(sv); + SvTEMP_off(sv); + } + else { assert(SvIMMORTAL(sv)); } + break; + case 3: + /* Something tried to die. Abandon constant folding. */ + /* Pretend the error never happened. */ + CLEAR_ERRSV(); + o->op_next = old_next; + break; + default: + JMPENV_POP; + /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */ + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + /* XXX note that this croak may fail as we've already blown away + * the stack - eg any nested evals */ + 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; + + if (PL_scopestack_ix > oldscope) + delete_eval_scope(); + + if (ret) + goto nope; + + /* OP_STRINGIFY and constant folding are used to implement qq. + Here the constant folding is an implementation detail that we + want to hide. If the stringify op is itself already marked + folded, however, then it is actually a folded join. */ + is_stringify = type == OP_STRINGIFY && !o->op_folded; + op_free(o); + assert(sv); + if (is_stringify) + SvPADTMP_off(sv); + else if (!SvIMMORTAL(sv)) { + SvPADTMP_on(sv); + SvREADONLY_on(sv); + } + newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); + if (!is_stringify) newop->op_folded = 1; + return newop; + + nope: + return o; +} + +static OP * +S_gen_constant_list(pTHX_ OP *o) +{ + dVAR; + OP *curop; + const SSize_t oldtmps_floor = PL_tmps_floor; + SV **svp; + AV *av; + + list(o); + if (PL_parser && PL_parser->error_count) + return o; /* Don't attempt to run with errors */ + + 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; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); + Perl_pp_anonlist(aTHX); + PL_tmps_floor = oldtmps_floor; + + OpTYPE_set(o, OP_RV2AV); + 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() */ + av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); + + /* 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); + SvREADONLY_on(*svp); + } + LINKLIST(o); + return list(o); +} + +/* +=head1 Optree Manipulation Functions +*/ + +/* List constructors */ + +/* +=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last + +Append an item to the list of ops contained directly within a list-type +op, returning the lengthened list. I<first> is the list-type op, +and I<last> is the op to append to the list. I<optype> specifies the +intended opcode for the list. If I<first> is not already a list of the +right type, it will be upgraded into one. If either I<first> or I<last> +is null, the other is returned unchanged. + +=cut +*/ + +OP * +Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) +{ + if (!first) + return last; + + if (!last) + return first; + + if (first->op_type != (unsigned)type + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + { + return newLISTOP(type, 0, first, last); + } + + op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); + first->op_flags |= OPf_KIDS; + return first; +} + +/* +=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last + +Concatenate the lists of ops contained directly within two list-type ops, +returning the combined list. I<first> and I<last> are the list-type ops +to concatenate. I<optype> specifies the intended opcode for the list. +If either I<first> or I<last> is not already a list of the right type, +it will be upgraded into one. If either I<first> or I<last> is null, +the other is returned unchanged. + +=cut +*/ + +OP * +Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) +{ + if (!first) + return last; + + if (!last) + return first; + + if (first->op_type != (unsigned)type) + return op_prepend_elem(type, first, last); + + if (last->op_type != (unsigned)type) + return op_append_elem(type, first, last); + + OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); + ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; + OpLASTSIB_set(((LISTOP*)first)->op_last, first); + first->op_flags |= (last->op_flags & OPf_KIDS); + + S_op_destroy(aTHX_ last); + + return first; +} + +/* +=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last + +Prepend an item to the list of ops contained directly within a list-type +op, returning the lengthened list. I<first> is the op to prepend to the +list, and I<last> is the list-type op. I<optype> specifies the intended +opcode for the list. If I<last> is not already a list of the right type, +it will be upgraded into one. If either I<first> or I<last> is null, +the other is returned unchanged. + +=cut +*/ + +OP * +Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) +{ + if (!first) + return last; + + if (!last) + return first; + + if (last->op_type == (unsigned)type) { + if (type == OP_LIST) { /* already a PUSHMARK there */ + /* 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 + op_sibling_splice(last, NULL, 0, first); + last->op_flags |= OPf_KIDS; + return last; + } + + return newLISTOP(type, 0, first, last); +} + +/* +=for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o + +Converts I<o> into a list op if it is not one already, and then converts it +into the specified I<type>, calling its check function, allocating a target if +it needs one, and folding constants. + +A list-type op is usually constructed one kid at a time via C<newLISTOP>, +C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to +C<op_convert_list> to make it the right type. + +=cut +*/ + +OP * +Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) +{ + dVAR; + if (type < 0) type = -type, flags |= OPf_SPECIAL; + if (!o || o->op_type != OP_LIST) + o = force_list(o, 0); + else + { + o->op_flags &= ~OPf_WANT; + o->op_private &= ~OPpLVAL_INTRO; + } + + if (!(PL_opargs[type] & OA_MARK)) + op_null(cLISTOPo->op_first); + else { + OP * const kid2 = OpSIBLING(cLISTOPo->op_first); + if (kid2 && kid2->op_type == OP_COREARGS) { + op_null(cLISTOPo->op_first); + kid2->op_private |= OPpCOREARGS_PUSHMARK; + } + } + + OpTYPE_set(o, type); + o->op_flags |= flags; + if (flags & OPf_FOLDED) + o->op_folded = 1; + + o = CHECKOP(type, o); + if (o->op_type != (unsigned)type) + return o; + + return fold_constants(op_integerize(op_std_init(o))); +} + +/* Constructors */ + + +/* +=head1 Optree construction + +=for apidoc Am|OP *|newNULLLIST + +Constructs, checks, and returns a new C<stub> op, which represents an +empty list expression. + +=cut +*/ + +OP * +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, bool nullit) +{ + if (!o || o->op_type != OP_LIST) { + OP *rest = NULL; + if (o) { + /* manually detach any siblings then add them back later */ + rest = OpSIBLING(o); + OpLASTSIB_set(o, NULL); + } + o = newLISTOP(OP_LIST, 0, o, NULL); + if (rest) + op_sibling_splice(o, cLISTOPo->op_last, 0, rest); + } + if (nullit) + op_null(o); + return o; +} + +/* +=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last + +Constructs, checks, and returns an op of any list type. I<type> is +the opcode. I<flags> gives the eight bits of C<op_flags>, except that +C<OPf_KIDS> will be set automatically if required. I<first> and I<last> +supply up to two ops to be direct children of the list op; they are +consumed by this function and become part of the constructed op tree. + +For most list operators, the check function expects all the kid ops to be +present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not +appropriate. What you want to do in that case is create an op of type +OP_LIST, append more children to it, and then call L</op_convert_list>. +See L</op_convert_list> for more information. + + +=cut +*/ + +OP * +Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) +{ + dVAR; + LISTOP *listop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP + || type == OP_CUSTOM); + + NewOp(1101, listop, 1, LISTOP); + + OpTYPE_set(listop, type); + if (first || last) + flags |= OPf_KIDS; + listop->op_flags = (U8)flags; + + if (!last && first) + last = first; + else if (!first && last) + first = last; + else if (first) + OpMORESIB_set(first, last); + listop->op_first = first; + listop->op_last = last; + if (type == OP_LIST) { + OP* const pushop = newOP(OP_PUSHMARK, 0); + OpMORESIB_set(pushop, first); + listop->op_first = pushop; + listop->op_flags |= OPf_KIDS; + if (!last) + listop->op_last = pushop; + } + if (listop->op_last) + OpLASTSIB_set(listop->op_last, (OP*)listop); + + return CHECKOP(type, listop); +} + +/* +=for apidoc Am|OP *|newOP|I32 type|I32 flags + +Constructs, checks, and returns an op of any base type (any type that +has no extra fields). I<type> is the opcode. I<flags> gives the +eight bits of C<op_flags>, and, shifted up eight bits, the eight bits +of C<op_private>. + +=cut +*/ + +OP * +Perl_newOP(pTHX_ I32 type, I32 flags) +{ + dVAR; + OP *o; + + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + + NewOp(1101, o, 1, OP); + OpTYPE_set(o, type); + o->op_flags = (U8)flags; + + o->op_next = o; + o->op_private = (U8)(0 | (flags >> 8)); + if (PL_opargs[type] & OA_RETSCALAR) + scalar(o); + if (PL_opargs[type] & OA_TARGET) + o->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, o); +} + +/* +=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first + +Constructs, checks, and returns an op of any unary type. I<type> is +the opcode. I<flags> gives the eight bits of C<op_flags>, except that +C<OPf_KIDS> will be set automatically if required, and, shifted up eight +bits, the eight bits of C<op_private>, except that the bit with value 1 +is automatically set. I<first> supplies an optional op to be the direct +child of the unary op; it is consumed by this function and become part +of the constructed op tree. + +=cut +*/ + +OP * +Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) +{ + dVAR; + UNOP *unop; + + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_SASSIGN + || type == OP_ENTERTRY + || type == OP_CUSTOM + || type == OP_NULL ); + + if (!first) + first = newOP(OP_STUB, 0); + if (PL_opargs[type] & OA_MARK) + first = force_list(first, 1); + + NewOp(1101, unop, 1, UNOP); + OpTYPE_set(unop, type); + unop->op_first = first; + unop->op_flags = (U8)(flags | OPf_KIDS); + unop->op_private = (U8)(1 | (flags >> 8)); + + if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */ + OpLASTSIB_set(first, (OP*)unop); + + unop = (UNOP*) CHECKOP(type, unop); + if (unop->op_next) + return (OP*)unop; + + return fold_constants(op_integerize(op_std_init((OP *) unop))); +} + +/* +=for apidoc newUNOP_AUX + +Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux +initialised to aux + +=cut +*/ + +OP * +Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux) +{ + dVAR; + UNOP_AUX *unop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX + || type == OP_CUSTOM); + + NewOp(1101, unop, 1, UNOP_AUX); + unop->op_type = (OPCODE)type; + unop->op_ppaddr = PL_ppaddr[type]; + unop->op_first = first; + unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0)); + unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8)); + unop->op_aux = aux; + + if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */ + OpLASTSIB_set(first, (OP*)unop); + + unop = (UNOP_AUX*) CHECKOP(type, unop); + + return op_std_init((OP *) unop); +} + +/* +=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first + +Constructs, checks, and returns an op of method type with a method name +evaluated at runtime. I<type> is the opcode. I<flags> gives the eight +bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically, +and, shifted up eight bits, the eight bits of C<op_private>, except that +the bit with value 1 is automatically set. I<dynamic_meth> supplies an +op which evaluates method name; it is consumed by this function and +become part of the constructed op tree. +Supported optypes: OP_METHOD. + +=cut +*/ + +static OP* +S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) { + dVAR; + METHOP *methop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP + || type == OP_CUSTOM); + + NewOp(1101, methop, 1, METHOP); + if (dynamic_meth) { + if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1); + methop->op_flags = (U8)(flags | OPf_KIDS); + methop->op_u.op_first = dynamic_meth; + methop->op_private = (U8)(1 | (flags >> 8)); + + if (!OpHAS_SIBLING(dynamic_meth)) + OpLASTSIB_set(dynamic_meth, (OP*)methop); + } + else { + assert(const_meth); + methop->op_flags = (U8)(flags & ~OPf_KIDS); + methop->op_u.op_meth_sv = const_meth; + methop->op_private = (U8)(0 | (flags >> 8)); + methop->op_next = (OP*)methop; + } + +#ifdef USE_ITHREADS + methop->op_rclass_targ = 0; +#else + methop->op_rclass_sv = NULL; +#endif + + OpTYPE_set(methop, type); + return CHECKOP(type, methop); +} + +OP * +Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) { + PERL_ARGS_ASSERT_NEWMETHOP; + return newMETHOP_internal(type, flags, dynamic_meth, NULL); +} + +/* +=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth + +Constructs, checks, and returns an op of method type with a constant +method name. I<type> is the opcode. I<flags> gives the eight bits of +C<op_flags>, and, shifted up eight bits, the eight bits of +C<op_private>. I<const_meth> supplies a constant method name; +it must be a shared COW string. +Supported optypes: OP_METHOD_NAMED. + +=cut +*/ + +OP * +Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) { + PERL_ARGS_ASSERT_NEWMETHOP_NAMED; + return newMETHOP_internal(type, flags, NULL, const_meth); +} + +/* +=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last + +Constructs, checks, and returns an op of any binary type. I<type> +is the opcode. I<flags> gives the eight bits of C<op_flags>, except +that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, +the eight bits of C<op_private>, except that the bit with value 1 or +2 is automatically set as required. I<first> and I<last> supply up to +two ops to be the direct children of the binary op; they are consumed +by this function and become part of the constructed op tree. + +=cut +*/ + +OP * +Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) +{ + dVAR; + BINOP *binop; + + ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM); + + NewOp(1101, binop, 1, BINOP); + + if (!first) + first = newOP(OP_NULL, 0); + + OpTYPE_set(binop, type); + binop->op_first = first; + binop->op_flags = (U8)(flags | OPf_KIDS); + if (!last) { + last = first; + binop->op_private = (U8)(1 | (flags >> 8)); + } + else { + binop->op_private = (U8)(2 | (flags >> 8)); + OpMORESIB_set(first, last); + } + + if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */ + OpLASTSIB_set(last, (OP*)binop); + + binop->op_last = OpSIBLING(binop->op_first); + if (binop->op_last) + OpLASTSIB_set(binop->op_last, (OP*)binop); + + binop = (BINOP*)CHECKOP(type, binop); + if (binop->op_next || binop->op_type != (OPCODE)type) + return (OP*)binop; + + return fold_constants(op_integerize(op_std_init((OP *)binop))); +} + +static int uvcompare(const void *a, const void *b) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__pure__; +static int uvcompare(const void *a, const void *b) +{ + if (*((const UV *)a) < (*(const UV *)b)) + return -1; + if (*((const UV *)a) > (*(const UV *)b)) + return 1; + if (*((const UV *)a+1) < (*(const UV *)b+1)) + return -1; + if (*((const UV *)a+1) > (*(const UV *)b+1)) + return 1; + return 0; +} + +static OP * +S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) +{ + SV * const tstr = ((SVOP*)expr)->op_sv; + SV * const rstr = + ((SVOP*)repl)->op_sv; + STRLEN tlen; + STRLEN rlen; + const U8 *t = (U8*)SvPV_const(tstr, tlen); + const U8 *r = (U8*)SvPV_const(rstr, rlen); + I32 i; + I32 j; + I32 grows = 0; + short *tbl; + + const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; + const I32 squash = o->op_private & OPpTRANS_SQUASH; + I32 del = o->op_private & OPpTRANS_DELETE; + SV* swash; + + PERL_ARGS_ASSERT_PMTRANS; + + PL_hints |= HINT_BLOCK_SCOPE; + + if (SvUTF8(tstr)) + o->op_private |= OPpTRANS_FROM_UTF; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; + + if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { + SV* const listsv = newSVpvs("# comment\n"); + SV* transv = NULL; + const U8* tend = t + tlen; + const U8* rend = r + rlen; + STRLEN ulen; + UV tfirst = 1; + UV tlast = 0; + IV tdiff; + STRLEN tcount = 0; + UV rfirst = 1; + UV rlast = 0; + IV rdiff; + STRLEN rcount = 0; + IV diff; + I32 none = 0; + U32 max = 0; + I32 bits; + I32 havefinal = 0; + U32 final = 0; + const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; + const I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + U8* tsave = NULL; + U8* rsave = NULL; + const U32 flags = UTF8_ALLOW_DEFAULT; + + if (!from_utf) { + STRLEN len = tlen; + t = tsave = bytes_to_utf8(t, &len); + tend = t + len; + } + if (!to_utf && rlen) { + STRLEN len = rlen; + r = rsave = bytes_to_utf8(r, &len); + rend = r + len; + } + +/* 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]; + UV *cp; + UV nextmin = 0; + Newx(cp, 2*tlen, UV); + i = 0; + transv = newSVpvs(""); + while (t < tend) { + cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags); + t += ulen; + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { + t++; + cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags); + t += ulen; + } + else { + cp[2*i+1] = cp[2*i]; + } + i++; + } + qsort(cp, i, 2*sizeof(UV), uvcompare); + for (j = 0; j < i; j++) { + UV val = cp[2*j]; + diff = val - nextmin; + if (diff > 0) { + t = uvchr_to_utf8(tmpbuf,nextmin); + sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); + if (diff > 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); + } + } + val = cp[2*j+1]; + if (val >= nextmin) + nextmin = val + 1; + } + t = uvchr_to_utf8(tmpbuf,nextmin); + sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); + { + U8 range_mark = ILLEGAL_UTF8_BYTE; + sv_catpvn(transv, (char *)&range_mark, 1); + } + t = uvchr_to_utf8(tmpbuf, 0x7fffffff); + sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); + t = (const U8*)SvPVX_const(transv); + tlen = SvCUR(transv); + tend = t + tlen; + Safefree(cp); + } + else if (!rlen && !del) { + r = t; rlen = tlen; rend = tend; + } + if (!squash) { + if ((!rlen && !del) || t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { + o->op_private |= OPpTRANS_IDENTICAL; + } + } + + while (t < tend || tfirst <= tlast) { + /* see if we need more "t" chars */ + if (tfirst > tlast) { + tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); + t += ulen; + if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ + t++; + tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags); + t += ulen; + } + else + tlast = tfirst; + } + + /* now see if we need more "r" chars */ + if (rfirst > rlast) { + if (r < rend) { + rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); + r += ulen; + if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */ + r++; + rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags); + r += ulen; + } + else + rlast = rfirst; + } + else { + if (!havefinal++) + final = rlast; + rfirst = rlast = 0xffffffff; + } + } + + /* now see which range will peter our first, if either. */ + tdiff = tlast - tfirst; + rdiff = rlast - rfirst; + tcount += tdiff + 1; + rcount += rdiff + 1; + + if (tdiff <= rdiff) + diff = tdiff; + else + diff = rdiff; + + if (rfirst == 0xffffffff) { + diff = tdiff; /* oops, pretend rdiff is infinite */ + if (diff > 0) + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", + (long)tfirst, (long)tlast); + else + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); + } + else { + if (diff > 0) + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", + (long)tfirst, (long)(tfirst + diff), + (long)rfirst); + else + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", + (long)tfirst, (long)rfirst); + + if (rfirst + diff > max) + max = rfirst + diff; + if (!grows) + grows = (tfirst < rfirst && + UNISKIP(tfirst) < UNISKIP(rfirst + diff)); + rfirst += diff + 1; + } + tfirst += diff + 1; + } + + none = ++max; + if (del) + del = ++max; + + if (max > 0xffff) + bits = 32; + else if (max > 0xff) + bits = 16; + else + bits = 8; + + swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); +#ifdef USE_ITHREADS + cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); + PAD_SETSV(cPADOPo->op_padix, swash); + SvPADTMP_on(swash); + SvREADONLY_on(swash); +#else + cSVOPo->op_sv = swash; +#endif + SvREFCNT_dec(listsv); + SvREFCNT_dec(transv); + + if (!del && havefinal && rlen) + (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, + newSVuv((UV)final), 0); + + Safefree(tsave); + Safefree(rsave); + + tlen = tcount; + rlen = rcount; + if (r < rend) + rlen++; + else if (rlast == 0xffffffff) + rlen = 0; + + goto warnins; + } + + tbl = (short*)PerlMemShared_calloc( + (o->op_private & OPpTRANS_COMPLEMENT) && + !(o->op_private & OPpTRANS_DELETE) ? 258 : 256, + sizeof(short)); + cPVOPo->op_pv = (char*)tbl; + if (complement) { + for (i = 0; i < (I32)tlen; i++) + tbl[t[i]] = -1; + for (i = 0, j = 0; i < 256; i++) { + if (!tbl[i]) { + if (j >= (I32)rlen) { + if (del) + tbl[i] = -2; + else if (rlen) + tbl[i] = r[j-1]; + else + tbl[i] = (short)i; + } + else { + if (i < 128 && r[j] >= 128) + grows = 1; + tbl[i] = r[j++]; + } + } + } + if (!del) { + if (!rlen) { + j = rlen; + if (!squash) + o->op_private |= OPpTRANS_IDENTICAL; + } + else if (j >= (I32)rlen) + j = rlen - 1; + else { + tbl = + (short *) + PerlMemShared_realloc(tbl, + (0x101+rlen-j) * sizeof(short)); + cPVOPo->op_pv = (char*)tbl; + } + tbl[0x100] = (short)(rlen - j); + for (i=0; i < (I32)rlen - j; i++) + tbl[0x101+i] = r[j+i]; + } + } + else { + if (!rlen && !del) { + r = t; rlen = tlen; + if (!squash) + o->op_private |= OPpTRANS_IDENTICAL; + } + else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { + o->op_private |= OPpTRANS_IDENTICAL; + } + for (i = 0; i < 256; i++) + tbl[i] = -1; + for (i = 0, j = 0; i < (I32)tlen; i++,j++) { + if (j >= (I32)rlen) { + if (del) { + if (tbl[t[i]] == -1) + tbl[t[i]] = -2; + continue; + } + --j; + } + if (tbl[t[i]] == -1) { + if (t[i] < 128 && r[j] >= 128) + grows = 1; + tbl[t[i]] = r[j]; + } + } + } + + warnins: + if(del && rlen == tlen) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen && !complement) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + } + + if (grows) + o->op_private |= OPpTRANS_GROWS; + op_free(expr); + op_free(repl); + + return o; +} + +/* +=for apidoc Am|OP *|newPMOP|I32 type|I32 flags + +Constructs, checks, and returns an op of any pattern matching type. +I<type> is the opcode. I<flags> gives the eight bits of C<op_flags> +and, shifted up eight bits, the eight bits of C<op_private>. + +=cut +*/ + +OP * +Perl_newPMOP(pTHX_ I32 type, I32 flags) +{ + dVAR; + PMOP *pmop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP + || type == OP_CUSTOM); + + NewOp(1101, pmop, 1, PMOP); + OpTYPE_set(pmop, type); + pmop->op_flags = (U8)flags; + pmop->op_private = (U8)(0 | (flags >> 8)); + if (PL_opargs[type] & OA_RETSCALAR) + scalar((OP *)pmop); + + if (PL_hints & HINT_RE_TAINT) + pmop->op_pmflags |= PMf_RETAINT; +#ifdef USE_LOCALE_CTYPE + if (IN_LC_COMPILETIME(LC_CTYPE)) { + set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); + } + else +#endif + if (IN_UNI_8_BIT) { + set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); + } + if (PL_hints & HINT_RE_FLAGS) { + SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0 + ); + if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags); + reflags = Perl_refcounted_he_fetch_pvn(aTHX_ + PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0 + ); + if (reflags && SvOK(reflags)) { + set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags)); + } + } + + +#ifdef USE_ITHREADS + assert(SvPOK(PL_regex_pad[0])); + if (SvCUR(PL_regex_pad[0])) { + /* Pop off the "packed" IV from the end. */ + SV *const repointer_list = PL_regex_pad[0]; + const char *p = SvEND(repointer_list) - sizeof(IV); + const IV offset = *((IV*)p); + + assert(SvCUR(repointer_list) % sizeof(IV) == 0); + + SvEND_set(repointer_list, p); + + pmop->op_pmoffset = offset; + /* This slot should be free, so assert this: */ + assert(PL_regex_pad[offset] == &PL_sv_undef); + } else { + SV * const repointer = &PL_sv_undef; + av_push(PL_regex_padav, repointer); + pmop->op_pmoffset = av_tindex(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); + } +#endif + + return CHECKOP(type, pmop); +} + +static void +S_set_haseval(pTHX) +{ + PADOFFSET i = 1; + PL_cv_has_eval = 1; + /* Any pad names in scope are potentially lvalues. */ + for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) { + PADNAME *pn = PAD_COMPNAME_SV(i); + if (!pn || !PadnameLEN(pn)) + continue; + if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax)) + S_mark_padname_lvalue(aTHX_ pn); + } +} + +/* Given some sort of match op o, and an expression expr containing a + * pattern, either compile expr into a regex and attach it to o (if it's + * constant), or convert expr into a runtime regcomp op sequence (if it's + * not) + * + * isreg indicates that the pattern is part of a regex construct, eg + * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or + * split "pattern", which aren't. In the former case, expr will be a list + * if the pattern contains more than one term (eg /a$b/). + * + * When the pattern has been compiled within a new anon CV (for + * qr/(?{...})/ ), then floor indicates the savestack level just before + * the new sub was created + */ + +OP * +Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) +{ + PMOP *pm; + LOGOP *rcop; + I32 repl_has_vars = 0; + bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); + bool is_compiletime; + bool has_code; + + PERL_ARGS_ASSERT_PMRUNTIME; + + if (is_trans) { + return pmtrans(o, expr, repl); + } + + /* find whether we have any runtime or code elements; + * at the same time, temporarily set the op_next of each DO block; + * then when we LINKLIST, this will cause the DO blocks to be excluded + * from the op_next chain (and from having LINKLIST recursively + * applied to them). We fix up the DOs specially later */ + + is_compiletime = 1; + has_code = 0; + if (expr->op_type == OP_LIST) { + OP *o; + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) { + if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { + has_code = 1; + assert(!o->op_next); + if (UNLIKELY(!OpHAS_SIBLING(o))) { + assert(PL_parser && PL_parser->error_count); + /* This can happen with qr/ (?{(^{})/. Just fake up + the op we were expecting to see, to avoid crashing + elsewhere. */ + op_sibling_splice(expr, o, 0, + newSVOP(OP_CONST, 0, &PL_sv_no)); + } + o->op_next = OpSIBLING(o); + } + else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) + is_compiletime = 0; + } + } + else if (expr->op_type != OP_CONST) + is_compiletime = 0; + + LINKLIST(expr); + + /* fix up DO blocks; treat each one as a separate little sub; + * also, mark any arrays as LIST/REF */ + + if (expr->op_type == OP_LIST) { + OP *o; + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) { + + if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { + assert( !(o->op_flags & OPf_WANT)); + /* push the array rather than its contents. The regex + * engine will retrieve and join the elements later */ + o->op_flags |= (OPf_WANT_LIST | OPf_REF); + continue; + } + + if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))) + continue; + o->op_next = NULL; /* undo temporary hack from above */ + scalar(o); + LINKLIST(o); + if (cLISTOPo->op_first->op_type == OP_LEAVE) { + LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first); + /* skip ENTER */ + assert(leaveop->op_first->op_type == OP_ENTER); + assert(OpHAS_SIBLING(leaveop->op_first)); + o->op_next = OpSIBLING(leaveop->op_first); + /* skip leave */ + assert(leaveop->op_flags & OPf_KIDS); + assert(leaveop->op_last->op_next == (OP*)leaveop); + leaveop->op_next = NULL; /* stop on last op */ + op_null((OP*)leaveop); + } + else { + /* skip SCOPE */ + OP *scope = cLISTOPo->op_first; + assert(scope->op_type == OP_SCOPE); + assert(scope->op_flags & OPf_KIDS); + scope->op_next = NULL; /* stop on last op */ + op_null(scope); + } + /* 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); + } + } + else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) { + assert( !(expr->op_flags & OPf_WANT)); + /* push the array rather than its contents. The regex + * engine will retrieve and join the elements later */ + expr->op_flags |= (OPf_WANT_LIST | OPf_REF); + } + + PL_hints |= HINT_BLOCK_SCOPE; + pm = (PMOP*)o; + assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV)); + + if (is_compiletime) { + U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + regexp_engine const *eng = current_re_engine(); + + if (o->op_flags & OPf_SPECIAL) + rx_flags |= RXf_SPLIT; + + if (!has_code || !eng->op_comp) { + /* compile-time simple constant pattern */ + + if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) { + /* whoops! we guessed that a qr// had a code block, but we + * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv + * that isn't required now. Note that we have to be pretty + * confident that nothing used that CV's pad while the + * regex was parsed, except maybe op targets for \Q etc. + * If there were any op targets, though, they should have + * been stolen by constant folding. + */ +#ifdef DEBUGGING + SSize_t i = 0; + assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); + while (++i <= AvFILLp(PL_comppad)) { + assert(!PL_curpad[i]); + } +#endif + /* But we know that one op is using this CV's slab. */ + cv_forget_slab(PL_compcv); + LEAVE_SCOPE(floor); + pm->op_pmflags &= ~PMf_HAS_CV; + } + + PM_SETRE(pm, + eng->op_comp + ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, pm->op_pmflags) + ); + op_free(expr); + } + else { + /* compile-time pattern that includes literal code blocks */ + REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL, + rx_flags, + (pm->op_pmflags | + ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0)) + ); + PM_SETRE(pm, re); + if (pm->op_pmflags & PMf_HAS_CV) { + CV *cv; + /* this QR op (and the anon sub we embed it in) is never + * actually executed. It's just a placeholder where we can + * squirrel away expr in op_code_list without the peephole + * optimiser etc processing it for a second time */ + OP *qr = newPMOP(OP_QR, 0); + ((PMOP*)qr)->op_code_list = expr; + + /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ + SvREFCNT_inc_simple_void(PL_compcv); + cv = newATTRSUB(floor, 0, NULL, NULL, qr); + ReANY(re)->qr_anoncv = cv; + + /* attach the anon CV to the pad so that + * pad_fixup_inner_anons() can find it */ + (void)pad_add_anon(cv, o->op_type); + SvREFCNT_inc_simple_void(cv); + } + else { + pm->op_code_list = expr; + } + } + } + else { + /* runtime pattern: build chain of regcomp etc ops */ + bool reglist; + PADOFFSET cv_targ = 0; + + reglist = isreg && expr->op_type == OP_LIST; + if (reglist) + op_null(expr); + + if (has_code) { + pm->op_code_list = expr; + /* don't free op_code_list; its ops are embedded elsewhere too */ + pm->op_pmflags |= PMf_CODELIST_PRIVATE; + } + + if (o->op_flags & OPf_SPECIAL) + pm->op_pmflags |= PMf_SPLIT; + + /* the OP_REGCMAYBE is a placeholder in the non-threaded case + * to allow its op_next to be pointed past the regcomp and + * preceding stacking ops; + * OP_REGCRESET is there to reset taint before executing the + * stacking ops */ + if (pm->op_pmflags & PMf_KEEP || TAINTING_get) + expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); + + if (pm->op_pmflags & PMf_HAS_CV) { + /* we have a runtime qr with literal code. This means + * that the qr// has been wrapped in a new CV, which + * means that runtime consts, vars etc will have been compiled + * against a new pad. So... we need to execute those ops + * within the environment of the new CV. So wrap them in a call + * to a new anon sub. i.e. for + * + * qr/a$b(?{...})/, + * + * we build an anon sub that looks like + * + * sub { "a", $b, '(?{...})' } + * + * and call it, passing the returned list to regcomp. + * Or to put it another way, the list of ops that get executed + * are: + * + * normal PMf_HAS_CV + * ------ ------------------- + * pushmark (for regcomp) + * pushmark (for entersub) + * anoncode + * srefgen + * entersub + * regcreset regcreset + * pushmark pushmark + * const("a") const("a") + * gvsv(b) gvsv(b) + * const("(?{...})") const("(?{...})") + * leavesub + * regcomp regcomp + */ + + SvREFCNT_inc_simple_void(PL_compcv); + CvLVALUE_on(PL_compcv); + /* these lines are just an unrolled newANONATTRSUB */ + expr = newSVOP(OP_ANONCODE, 0, + MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); + cv_targ = expr->op_targ; + expr = newUNOP(OP_REFGEN, 0, expr); + + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); + } + + rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), 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/(?{..})/ */ + if (PL_hints & HINT_RE_EVAL) + S_set_haseval(aTHX); + + /* establish postfix order */ + if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) { + LINKLIST(expr); + rcop->op_next = expr; + ((UNOP*)expr)->op_first->op_next = (OP*)rcop; + } + else { + rcop->op_next = LINKLIST(expr); + expr->op_next = (OP*)rcop; + } + + op_prepend_elem(o->op_type, scalar((OP*)rcop), o); + } + + if (repl) { + OP *curop = repl; + bool konst; + /* 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) + { + OP *sib; + OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; + if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid)) + && !OpHAS_SIBLING(sib)) + curop = sib; + } + if (curop->op_type == OP_CONST) + konst = TRUE; + else if (( (curop->op_type == OP_RV2SV || + curop->op_type == OP_RV2AV || + curop->op_type == OP_RV2HV || + curop->op_type == OP_RV2GV) + && cUNOPx(curop)->op_first + && cUNOPx(curop)->op_first->op_type == OP_GV ) + || curop->op_type == OP_PADSV + || curop->op_type == OP_PADAV + || curop->op_type == OP_PADHV + || curop->op_type == OP_PADANY) { + repl_has_vars = 1; + konst = TRUE; + } + else konst = FALSE; + if (konst + && !(repl_has_vars + && (!PM_GETRE(pm) + || !RX_PRELEN(PM_GETRE(pm)) + || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN))) + { + pm->op_pmflags |= PMf_CONST; /* const for long enough */ + op_prepend_elem(o->op_type, scalar(repl), o); + } + else { + rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o); + rcop->op_private = 1; + + /* establish postfix order */ + rcop->op_next = LINKLIST(repl); + repl->op_next = (OP*)rcop; + + pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); + assert(!(pm->op_pmflags & PMf_ONCE)); + pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); + rcop->op_next = 0; + } + } + + return (OP*)pm; +} + +/* +=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv + +Constructs, checks, and returns an op of any type that involves an +embedded SV. I<type> is the opcode. I<flags> gives the eight bits +of C<op_flags>. I<sv> gives the SV to embed in the op; this function +takes ownership of one reference to it. + +=cut +*/ + +OP * +Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) +{ + dVAR; + SVOP *svop; + + PERL_ARGS_ASSERT_NEWSVOP; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); + + NewOp(1101, svop, 1, SVOP); + OpTYPE_set(svop, type); + svop->op_sv = sv; + svop->op_next = (OP*)svop; + svop->op_flags = (U8)flags; + svop->op_private = (U8)(0 | (flags >> 8)); + if (PL_opargs[type] & OA_RETSCALAR) + scalar((OP*)svop); + if (PL_opargs[type] & OA_TARGET) + svop->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, svop); +} + +/* +=for apidoc Am|OP *|newDEFSVOP| + +Constructs and returns an op to access C<$_>, either as a lexical +variable (if declared as C<my $_>) in the current scope, or the +global C<$_>. + +=cut +*/ + +OP * +Perl_newDEFSVOP(pTHX) +{ + 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)); + } + else { + OP * const o = newOP(OP_PADSV, 0); + o->op_targ = offset; + return o; + } +} + +#ifdef USE_ITHREADS + +/* +=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv + +Constructs, checks, and returns an op of any type that involves a +reference to a pad element. I<type> is the opcode. I<flags> gives the +eight bits of C<op_flags>. A pad slot is automatically allocated, and +is populated with I<sv>; this function takes ownership of one reference +to it. + +This function only exists if Perl has been compiled to use ithreads. + +=cut +*/ + +OP * +Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) +{ + dVAR; + PADOP *padop; + + PERL_ARGS_ASSERT_NEWPADOP; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); + + NewOp(1101, padop, 1, PADOP); + OpTYPE_set(padop, type); + 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); + padop->op_next = (OP*)padop; + padop->op_flags = (U8)flags; + if (PL_opargs[type] & OA_RETSCALAR) + scalar((OP*)padop); + if (PL_opargs[type] & OA_TARGET) + padop->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, padop); +} + +#endif /* USE_ITHREADS */ + +/* +=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv + +Constructs, checks, and returns an op of any type that involves an +embedded reference to a GV. I<type> is the opcode. I<flags> gives the +eight bits of C<op_flags>. I<gv> identifies the GV that the op should +reference; calling this function does not transfer ownership of any +reference to it. + +=cut +*/ + +OP * +Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) +{ + PERL_ARGS_ASSERT_NEWGVOP; + +#ifdef USE_ITHREADS + return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); +#else + return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); +#endif +} + +/* +=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv + +Constructs, checks, and returns an op of any type that involves an +embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives +the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which +must have been allocated using C<PerlMemShared_malloc>; the memory will +be freed when the op is destroyed. + +=cut +*/ + +OP * +Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) +{ + dVAR; + const bool utf8 = cBOOL(flags & SVf_UTF8); + PVOP *pvop; + + flags &= ~SVf_UTF8; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || type == OP_RUNCV || type == OP_CUSTOM + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + + NewOp(1101, pvop, 1, PVOP); + OpTYPE_set(pvop, type); + pvop->op_pv = pv; + pvop->op_next = (OP*)pvop; + pvop->op_flags = (U8)flags; + pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; + if (PL_opargs[type] & OA_RETSCALAR) + scalar((OP*)pvop); + if (PL_opargs[type] & OA_TARGET) + pvop->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, pvop); +} + +void +Perl_package(pTHX_ OP *o) +{ + SV *const sv = cSVOPo->op_sv; + + PERL_ARGS_ASSERT_PACKAGE; + + SAVEGENERICSV(PL_curstash); + save_item(PL_curstname); + + PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD)); + + sv_setsv(PL_curstname, sv); + + PL_hints |= HINT_BLOCK_SCOPE; + PL_parser->copline = NOLINE; + + op_free(o); +} + +void +Perl_package_version( pTHX_ OP *v ) +{ + U32 savehints = PL_hints; + PERL_ARGS_ASSERT_PACKAGE_VERSION; + PL_hints &= ~HINT_STRICT_VARS; + sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); + PL_hints = savehints; + op_free(v); +} + +void +Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) +{ + OP *pack; + OP *imop; + OP *veop; + SV *use_version = NULL; + + PERL_ARGS_ASSERT_UTILIZE; + + if (idop->op_type != OP_CONST) + Perl_croak(aTHX_ "Module name must be constant"); + + veop = NULL; + + if (version) { + SV * const vesv = ((SVOP*)version)->op_sv; + + if (!arg && !SvNIOKp(vesv)) { + arg = version; + } + else { + OP *pack; + SV *meth; + + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) + Perl_croak(aTHX_ "Version number must be a constant number"); + + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + + /* Fake up a method call to VERSION */ + meth = newSVpvs_share("VERSION"); + veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, version), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); + } + } + + /* Fake up an import/unimport */ + if (arg && arg->op_type == OP_STUB) { + imop = arg; /* no import on explicit () */ + } + else if (SvNIOKp(((SVOP*)idop)->op_sv)) { + imop = NULL; /* use 5.0; */ + if (aver) + use_version = ((SVOP*)idop)->op_sv; + else + idop->op_private |= OPpCONST_NOVER; + } + else { + SV *meth; + + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + + /* Fake up a method call to import/unimport */ + meth = aver + ? newSVpvs_share("import") : newSVpvs_share("unimport"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth) + )); + } + + /* Fake up the BEGIN {}, which does its thing immediately. */ + newATTRSUB(floor, + newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), + NULL, + NULL, + op_append_elem(OP_LINESEQ, + op_append_elem(OP_LINESEQ, + newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), + newSTATEOP(0, NULL, veop)), + newSTATEOP(0, NULL, imop) )); + + if (use_version) { + /* Enable the + * feature bundle that corresponds to the required version. */ + use_version = sv_2mortal(new_version(use_version)); + S_enable_feature_bundle(aTHX_ use_version); + + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (vcmp(use_version, + sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints |= HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints |= HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints |= HINT_STRICT_VARS; + } + /* otherwise they are off */ + else { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints &= ~HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints &= ~HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints &= ~HINT_STRICT_VARS; + } + } + + /* The "did you use incorrect case?" warning used to be here. + * The problem is that on case-insensitive filesystems one + * might get false positives for "use" (and "require"): + * "use Strict" or "require CARP" will work. This causes + * portability problems for the script: in case-strict + * filesystems the script will stop working. + * + * The "incorrect case" warning checked whether "use Foo" + * imported "Foo" to your namespace, but that is wrong, too: + * there is no requirement nor promise in the language that + * a Foo.pm should or would contain anything in package "Foo". + * + * There is very little Configure-wise that can be done, either: + * the case-sensitivity of the build filesystem of Perl does not + * help in guessing the case-sensitivity of the runtime environment. + */ + + PL_hints |= HINT_BLOCK_SCOPE; + PL_parser->copline = NOLINE; + COP_SEQMAX_INC; /* Purely for B::*'s benefit */ +} + +/* +=head1 Embedding Functions + +=for apidoc load_module + +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 +similar to C<use Foo::Bar VERSION>. The optional trailing SV* +arguments can be used to specify arguments to the module's import() +method, similar to C<use Foo::Bar VERSION LIST>. They must be +terminated with a final NULL pointer. Note that this list can only +be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. +Otherwise at least a single NULL pointer to designate the default +import list is required. + +The reference count for each specified C<SV*> parameter is decremented. + +=cut */ + +void +Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + + PERL_ARGS_ASSERT_LOAD_MODULE; + + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#ifdef PERL_IMPLICIT_CONTEXT +void +Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) +{ + dTHX; + va_list args; + PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} +#endif + +void +Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) +{ + OP *veop, *imop; + OP * const modname = newSVOP(OP_CONST, 0, name); + + PERL_ARGS_ASSERT_VLOAD_MODULE; + + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + + /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure + * 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. + * The ENTER/LEAVE pair protect callers from any side effects of use. */ + + ENTER; + SAVEVPTR(PL_curcop); + lex_start(NULL, NULL, LEX_START_SAME_FILTER); + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + 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) +{ + OP *doop; + GV *gv; + + PERL_ARGS_ASSERT_DOFILE; + + if (!force_builtin && (gv = gv_override("do", 2))) { + doop = S_new_entersubop(aTHX_ gv, term); + } + else { + doop = newUNOP(OP_DOFILE, 0, scalar(term)); + } + return doop; +} + +/* +=head1 Optree construction + +=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval + +Constructs, checks, and returns an C<lslice> (list slice) op. I<flags> +gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will +be set automatically, and, shifted up eight bits, the eight bits of +C<op_private>, except that the bit with value 1 or 2 is automatically +set as required. I<listval> and I<subscript> supply the parameters of +the slice; they are consumed by this function and become part of the +constructed op tree. + +=cut +*/ + +OP * +Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) +{ + return newBINOP(OP_LSLICE, flags, + list(force_list(subscript, 1)), + list(force_list(listval, 1)) ); +} + +#define ASSIGN_LIST 1 +#define ASSIGN_REF 2 + +STATIC I32 +S_assignment_type(pTHX_ const OP *o) +{ + unsigned type; + U8 flags; + U8 ret; + + if (!o) + return TRUE; + + if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) + o = cUNOPo->op_first; + + flags = o->op_flags; + type = o->op_type; + if (type == OP_COND_EXPR) { + OP * const sib = OpSIBLING(cLOGOPo->op_first); + const I32 t = assignment_type(sib); + const I32 f = assignment_type(OpSIBLING(sib)); + + if (t == ASSIGN_LIST && f == ASSIGN_LIST) + return ASSIGN_LIST; + if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST)) + yyerror("Assignment to both a list and a scalar"); + return FALSE; + } + + if (type == OP_SREFGEN) + { + OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; + type = kid->op_type; + flags |= kid->op_flags; + if (!(flags & OPf_PARENS) + && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV || + kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV )) + return ASSIGN_REF; + ret = ASSIGN_REF; + } + else ret = 0; + + if (type == OP_LIST && + (flags & OPf_WANT) == OPf_WANT_SCALAR && + o->op_private & OPpLVAL_INTRO) + return ret; + + if (type == OP_LIST || flags & OPf_PARENS || + type == OP_RV2AV || type == OP_RV2HV || + type == OP_ASLICE || type == OP_HSLICE || + type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN) + return TRUE; + + if (type == OP_PADAV || type == OP_PADHV) + return TRUE; + + if (type == OP_RV2SV) + return ret; + + return ret; +} + +/* + Helper function for newASSIGNOP to detect commonality between the + lhs and the rhs. (It is actually called very indirectly. newASSIGNOP + flags the op and the peephole optimizer calls this helper function + if the flag is set.) Marks all variables with PL_generation. If it + returns TRUE the assignment must be able to handle common variables. + + PL_generation sorcery: + An assignment like ($a,$b) = ($c,$d) is easier than + ($a,$b) = ($c,$a), since there is no need for temporary vars. + To detect whether there are common vars, the global var + PL_generation is incremented for each assign op we compile. + Then, while compiling the assign op, we run through all the + variables on both sides of the assignment, setting a spare slot + in each of them to PL_generation. If any of them already have + that value, we know we've got commonality. Also, if the + generation number is already set to PERL_INT_MAX, then + the variable is involved in aliasing, so we also have + potential commonality in that case. We could use a + single bit marker, but then we'd have to make 2 passes, first + to clear the flag, then to test and set it. And that + wouldn't help with aliasing, either. To find somewhere + to store these values, evil chicanery is done with SvUVX(). +*/ +PERL_STATIC_INLINE bool +S_aassign_common_vars(pTHX_ OP* o) +{ + OP *curop; + for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { + if (PL_opargs[curop->op_type] & OA_DANGEROUS) { + if (curop->op_type == OP_GV || curop->op_type == OP_GVSV + || curop->op_type == OP_AELEMFAST) { + GV *gv = cGVOPx_gv(curop); + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) + return TRUE; + GvASSIGN_GENERATION_set(gv, PL_generation); + } + else if (curop->op_type == OP_PADSV || + curop->op_type == OP_PADAV || + curop->op_type == OP_PADHV || + curop->op_type == OP_AELEMFAST_LEX || + curop->op_type == OP_PADANY) + { + padcheck: + if (PAD_COMPNAME_GEN(curop->op_targ) + == (STRLEN)PL_generation + || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) + return TRUE; + PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation); + + } + else if (curop->op_type == OP_RV2CV) + return TRUE; + else if (curop->op_type == OP_RV2SV || + curop->op_type == OP_RV2AV || + curop->op_type == OP_RV2HV || + curop->op_type == OP_RV2GV) { + if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */ + return TRUE; + } + else if (curop->op_type == OP_PUSHRE) { + GV *const gv = +#ifdef USE_ITHREADS + ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff + ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)) + : NULL; +#else + ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; +#endif + if (gv) { + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) + return TRUE; + GvASSIGN_GENERATION_set(gv, PL_generation); + } + else if (curop->op_targ) + goto padcheck; + } + else if (curop->op_type == OP_PADRANGE) + /* Ignore padrange; checking its siblings is sufficient. */ + continue; + else + return TRUE; + } + else if (PL_opargs[curop->op_type] & OA_TARGLEX + && curop->op_private & OPpTARGET_MY) + goto padcheck; + + if (curop->op_flags & OPf_KIDS) { + if (aassign_common_vars(curop)) + return TRUE; + } + } + return FALSE; +} + +/* This variant only handles lexical aliases. It is called when + newASSIGNOP decides that we don’t have any common vars, as lexical ali- + ases trump that decision. */ +PERL_STATIC_INLINE bool +S_aassign_common_vars_aliases_only(pTHX_ OP *o) +{ + OP *curop; + for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) { + if ((curop->op_type == OP_PADSV || + curop->op_type == OP_PADAV || + curop->op_type == OP_PADHV || + curop->op_type == OP_AELEMFAST_LEX || + curop->op_type == OP_PADANY || + ( PL_opargs[curop->op_type] & OA_TARGLEX + && curop->op_private & OPpTARGET_MY )) + && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) + return TRUE; + + if (curop->op_type == OP_PUSHRE && curop->op_targ + && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX) + return TRUE; + + if (curop->op_flags & OPf_KIDS) { + if (S_aassign_common_vars_aliases_only(aTHX_ curop)) + return TRUE; + } + } + return FALSE; +} + +/* +=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right + +Constructs, checks, and returns an assignment op. I<left> and I<right> +supply the parameters of the assignment; they are consumed by this +function and become part of the constructed op tree. + +If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then +a suitable conditional optree is constructed. If I<optype> is the opcode +of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that +performs the binary operation and assigns the result to the left argument. +Either way, if I<optype> is non-zero then I<flags> has no effect. + +If I<optype> is zero, then a plain scalar or list assignment is +constructed. Which type of assignment it is is automatically determined. +I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> +will be set automatically, and, shifted up eight bits, the eight bits +of C<op_private>, except that the bit with value 1 or 2 is automatically +set as required. + +=cut +*/ + +OP * +Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) +{ + OP *o; + I32 assign_type; + + if (optype) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + return newLOGOP(optype, 0, + op_lvalue(scalar(left), optype), + newUNOP(OP_SASSIGN, 0, scalar(right))); + } + else { + return newBINOP(optype, OPf_STACKED, + op_lvalue(scalar(left), optype), scalar(right)); + } + } + + if ((assign_type = assignment_type(left)) == ASSIGN_LIST) { + static const char no_list_state[] = "Initialization of state variables" + " in list context currently forbidden"; + 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, 1)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); + o->op_private = (U8)(0 | (flags >> 8)); + + if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) + { + OP* lop = ((LISTOP*)left)->op_first; + maybe_common_vars = FALSE; + while (lop) { + if (lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) { + if (!(lop->op_private & OPpLVAL_INTRO)) + maybe_common_vars = TRUE; + + if (lop->op_private & OPpPAD_STATE) { + if (left->op_private & OPpLVAL_INTRO) { + /* Each variable in state($a, $b, $c) = ... */ + } + else { + /* Each state variable in + (state $a, my $b, our $c, $d, undef) = ... */ + } + yyerror(no_list_state); + } else { + /* Each my variable in + (state $a, my $b, our $c, $d, undef) = ... */ + } + } else if (lop->op_type == OP_UNDEF || + 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 = OpSIBLING(lop); + } + } + else if ((left->op_private & OPpLVAL_INTRO) + && ( left->op_type == OP_PADSV + || left->op_type == OP_PADAV + || left->op_type == OP_PADHV + || left->op_type == OP_PADANY)) + { + if (left->op_type == OP_PADSV) maybe_common_vars = FALSE; + if (left->op_private & OPpPAD_STATE) { + /* All single variable list context state assignments, hence + state ($a) = ... + (state $a) = ... + state @a = ... + state (@a) = ... + (state @a) = ... + state %a = ... + state (%a) = ... + (state %a) = ... + */ + yyerror(no_list_state); + } + } + + if (maybe_common_vars) { + /* The peephole optimizer will do the full check and pos- + sibly turn this off. */ + o->op_private |= OPpASSIGN_COMMON; + } + + if (right && right->op_type == OP_SPLIT + && !(right->op_flags & OPf_STACKED)) { + OP* tmpop = ((LISTOP*)right)->op_first; + PMOP * const pm = (PMOP*)tmpop; + assert (tmpop && (tmpop->op_type == OP_PUSHRE)); + if ( +#ifdef USE_ITHREADS + !pm->op_pmreplrootu.op_pmtargetoff +#else + !pm->op_pmreplrootu.op_pmtargetgv +#endif + && !pm->op_targ + ) { + if (!(left->op_private & OPpLVAL_INTRO) && + ( (left->op_type == OP_RV2AV && + (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV) + || left->op_type == OP_PADAV ) + ) { + if (tmpop != (OP *)pm) { +#ifdef USE_ITHREADS + pm->op_pmreplrootu.op_pmtargetoff + = cPADOPx(tmpop)->op_padix; + cPADOPx(tmpop)->op_padix = 0; /* steal it */ +#else + pm->op_pmreplrootu.op_pmtargetgv + = MUTABLE_GV(cSVOPx(tmpop)->op_sv); + cSVOPx(tmpop)->op_sv = NULL; /* steal it */ +#endif + right->op_private |= + left->op_private & OPpOUR_INTRO; + } + else { + pm->op_targ = left->op_targ; + left->op_targ = 0; /* filch it */ + } + detach_split: + tmpop = cUNOPo->op_first; /* to list (nulled) */ + tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ + /* detach rest of siblings from o subtree, + * and free subtree */ + op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); + op_free(o); /* blow off assign */ + right->op_flags &= ~OPf_WANT; + /* "I don't know and I don't care." */ + return right; + } + else if (left->op_type == OP_RV2AV + || left->op_type == OP_PADAV) + { + /* Detach the array. */ +#ifdef DEBUGGING + OP * const ary = +#endif + op_sibling_splice(cBINOPo->op_last, + cUNOPx(cBINOPo->op_last) + ->op_first, 1, NULL); + assert(ary == left); + /* Attach it to the split. */ + op_sibling_splice(right, cLISTOPx(right)->op_last, + 0, left); + right->op_flags |= OPf_STACKED; + /* Detach split and expunge aassign as above. */ + goto detach_split; + } + else if (PL_modcount < RETURN_UNLIMITED_NUMBER && + ((LISTOP*)right)->op_last->op_type == OP_CONST) + { + SV ** const svp = + &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV * const sv = *svp; + if (SvIOK(sv) && SvIVX(sv) == 0) + { + if (right->op_private & OPpSPLIT_IMPLIM) { + /* our own SV, created in ck_split */ + SvREADONLY_off(sv); + sv_setiv(sv, PL_modcount+1); + } + else { + /* SV may belong to someone else */ + SvREFCNT_dec(sv); + *svp = newSViv(PL_modcount+1); + } + } + } + } + } + return o; + } + if (assign_type == ASSIGN_REF) + return newBINOP(OP_REFASSIGN, flags, scalar(right), left); + if (!right) + right = newOP(OP_UNDEF, 0); + if (right->op_type == OP_READLINE) { + right->op_flags |= OPf_STACKED; + return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN), + scalar(right)); + } + else { + o = newBINOP(OP_SASSIGN, flags, + scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); + } + return o; +} + +/* +=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o + +Constructs a state op (COP). The state op is normally a C<nextstate> op, +but will be a C<dbstate> op if debugging is enabled for currently-compiled +code. The state op is populated from C<PL_curcop> (or C<PL_compiling>). +If I<label> is non-null, it supplies the name of a label to attach to +the state op; this function takes ownership of the memory pointed at by +I<label>, and will free it. I<flags> gives the eight bits of C<op_flags> +for the state op. + +If I<o> is null, the state op is returned. Otherwise the state op is +combined with I<o> into a C<lineseq> list op, which is returned. I<o> +is consumed by this function and becomes part of the returned op tree. + +=cut +*/ + +OP * +Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) +{ + dVAR; + const U32 seq = intro_my(); + const U32 utf8 = flags & SVf_UTF8; + COP *cop; + + PL_parser->parsed_sub = 0; + + flags &= ~SVf_UTF8; + + NewOp(1101, cop, 1, COP); + if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { + OpTYPE_set(cop, OP_DBSTATE); + } + else { + OpTYPE_set(cop, OP_NEXTSTATE); + } + cop->op_flags = (U8)flags; + CopHINTS_set(cop, PL_hints); +#ifdef VMS + if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH; +#endif + cop->op_next = (OP*)cop; + + cop->cop_seq = seq; + cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); + if (label) { + Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + + PL_hints |= HINT_BLOCK_SCOPE; + /* It seems that we need to defer freeing this pointer, as other parts + of the grammar end up wanting to copy it after this op has been + created. */ + SAVEFREEPV(label); + } + + 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); + PL_parser->copline = NOLINE; + } +#ifdef USE_ITHREADS + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ +#else + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); +#endif + CopSTASH_set(cop, PL_curstash); + + 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, CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); + SvIV_set(*svp, PTR2IV(cop)); + } + } + } + + if (flags & OPf_SPECIAL) + op_null((OP*)cop); + return op_prepend_elem(OP_LINESEQ, (OP*)cop, o); +} + +/* +=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other + +Constructs, checks, and returns a logical (flow control) op. I<type> +is the opcode. I<flags> gives the eight bits of C<op_flags>, except +that C<OPf_KIDS> will be set automatically, and, shifted up eight bits, +the eight bits of C<op_private>, except that the bit with value 1 is +automatically set. I<first> supplies the expression controlling the +flow, and I<other> supplies the side (alternate) chain of ops; they are +consumed by this function and become part of the constructed op tree. + +=cut +*/ + +OP * +Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) +{ + PERL_ARGS_ASSERT_NEWLOGOP; + + return new_logop(type, flags, &first, &other); +} + +STATIC OP * +S_search_const(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_SEARCH_CONST; + + switch (o->op_type) { + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) + return search_const(cUNOPo->op_first); + break; + case OP_LEAVE: + case OP_SCOPE: + case OP_LINESEQ: + { + OP *kid; + if (!(o->op_flags & OPf_KIDS)) + return NULL; + kid = cLISTOPo->op_first; + do { + switch (kid->op_type) { + case OP_ENTER: + case OP_NULL: + case OP_NEXTSTATE: + kid = OpSIBLING(kid); + break; + default: + if (kid != cLISTOPo->op_last) + return NULL; + goto last; + } + } while (kid); + if (!kid) + kid = cLISTOPo->op_last; + last: + return search_const(kid); + } + } + + return NULL; +} + +STATIC OP * +S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) +{ + dVAR; + LOGOP *logop; + OP *o; + OP *first; + OP *other; + OP *cstop = NULL; + int prepend_not = 0; + + PERL_ARGS_ASSERT_NEW_LOGOP; + + 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)); + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP + || type == OP_CUSTOM); + + scalarboolean(first); + /* optimize AND and OR ops that have NOTs as children */ + if (first->op_type == OP_NOT + && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ + ) { + if (type == OP_AND || type == OP_OR) { + if (type == OP_AND) + type = OP_OR; + else + type = OP_AND; + op_null(first); + if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ + op_null(other); + prepend_not = 1; /* prepend a NOT op later */ + } + } + } + /* search for a constant op that could let us fold the test */ + if ((cstop = search_const(first))) { + if (cstop->op_private & OPpCONST_STRICT) + no_bareword_allowed(cstop); + else if ((cstop->op_private & OPpCONST_BARE)) + Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); + if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { + *firstp = NULL; + if (other->op_type == OP_CONST) + other->op_private |= OPpCONST_SHORTCIRCUIT; + op_free(first); + if (other->op_type == OP_LEAVE) + other = newUNOP(OP_NULL, OPf_SPECIAL, other); + else if (other->op_type == OP_MATCH + || other->op_type == OP_SUBST + || other->op_type == OP_TRANSR + || other->op_type == OP_TRANS) + /* Mark the op as being unbindable with =~ */ + other->op_flags |= OPf_SPECIAL; + + other->op_folded = 1; + return other; + } + else { + /* check for C<my $x if 0>, or C<my($x,$y) if 0> */ + const OP *o2 = other; + if ( ! (o2->op_type == OP_LIST + && (( o2 = cUNOPx(o2)->op_first)) + && o2->op_type == OP_PUSHMARK + && (( o2 = OpSIBLING(o2))) ) + ) + o2 = other; + if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV + || o2->op_type == OP_PADHV) + && o2->op_private & OPpLVAL_INTRO + && !(o2->op_private & OPpPAD_STATE)) + { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Deprecated use of my() in false conditional"); + } + + *otherp = NULL; + if (cstop->op_type == OP_CONST) + cstop->op_private |= OPpCONST_SHORTCIRCUIT; + op_free(other); + return first; + } + } + else if ((first->op_flags & OPf_KIDS) && type != OP_DOR + && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */ + { + const OP * const k1 = ((UNOP*)first)->op_first; + const OP * const k2 = OpSIBLING(k1); + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + { + warnop = k2->op_type; + } + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + || k1->op_type == OP_EACH + || k1->op_type == OP_AEACH) + { + warnop = ((k1->op_type == OP_NULL) + ? (OPCODE)k1->op_targ : k1->op_type); + } + break; + } + if (warnop) { + const line_t oldline = CopLINE(PL_curcop); + /* This ensures that warnings are reported at the first line + of the construction, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Value of %s%s can be \"0\"; test with defined()", + PL_op_desc[warnop], + ((warnop == OP_READLINE || warnop == OP_GLOB) + ? " construct" : "() operator")); + CopLINE_set(PL_curcop, oldline); + } + } + + if (!other) + return first; + + if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) + other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ + + logop = S_alloc_LOGOP(aTHX_ type, first, 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; + assert(!OpHAS_SIBLING(first)); + op_sibling_splice((OP*)logop, first, 0, other); + + CHECKOP(type,logop); + + o = newUNOP(prepend_not ? OP_NOT : OP_NULL, + PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, + (OP*)logop); + other->op_next = o; + + return o; +} + +/* +=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop + +Constructs, checks, and returns a conditional-expression (C<cond_expr>) +op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS> +will be set automatically, and, shifted up eight bits, the eight bits of +C<op_private>, except that the bit with value 1 is automatically set. +I<first> supplies the expression selecting between the two branches, +and I<trueop> and I<falseop> supply the branches; they are consumed by +this function and become part of the constructed op tree. + +=cut +*/ + +OP * +Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) +{ + dVAR; + LOGOP *logop; + OP *start; + OP *o; + OP *cstop; + + PERL_ARGS_ASSERT_NEWCONDOP; + + if (!falseop) + return newLOGOP(OP_AND, 0, first, trueop); + if (!trueop) + return newLOGOP(OP_OR, 0, first, falseop); + + scalarboolean(first); + if ((cstop = search_const(first))) { + /* Left or right arm of the conditional? */ + const bool left = SvTRUE(((SVOP*)cstop)->op_sv); + OP *live = left ? trueop : falseop; + OP *const dead = left ? falseop : trueop; + if (cstop->op_private & OPpCONST_BARE && + cstop->op_private & OPpCONST_STRICT) { + no_bareword_allowed(cstop); + } + 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; + live->op_folded = 1; + return live; + } + logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop)); + logop->op_flags |= (U8)flags; + logop->op_private = (U8)(1 | (flags >> 8)); + logop->op_next = LINKLIST(falseop); + + CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ + logop); + + /* establish postfix order */ + start = LINKLIST(first); + first->op_next = (OP*)logop; + + /* 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; + + o->op_next = start; + return o; +} + +/* +=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right + +Constructs and returns a C<range> op, with subordinate C<flip> and +C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the +C<flip> op and, shifted up eight bits, the eight bits of C<op_private> +for both the C<flip> and C<range> ops, except that the bit with value +1 is automatically set. I<left> and I<right> supply the expressions +controlling the endpoints of the range; they are consumed by this function +and become part of the constructed op tree. + +=cut +*/ + +OP * +Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) +{ + LOGOP *range; + OP *flip; + OP *flop; + OP *leftstart; + OP *o; + + PERL_ARGS_ASSERT_NEWRANGE; + + range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right)); + range->op_flags = OPf_KIDS; + leftstart = LINKLIST(left); + range->op_private = (U8)(1 | (flags >> 8)); + + /* 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); + flop = newUNOP(OP_FLOP, 0, flip); + o = newUNOP(OP_NULL, 0, flop); + LINKLIST(flop); + range->op_next = leftstart; + + left->op_next = flip; + right->op_next = flop; + + range->op_targ = + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); + sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); + flip->op_targ = + pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);; + sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); + SvPADTMP_on(PAD_SV(flip->op_targ)); + + flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; + flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; + + /* check barewords before they might be optimized aways */ + if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT) + no_bareword_allowed(left); + if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT) + no_bareword_allowed(right); + + flip->op_next = o; + if (!flip->op_private || !flop->op_private) + LINKLIST(o); /* blow off optimizer unless constant */ + + return o; +} + +/* +=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block + +Constructs, checks, and returns an op tree expressing a loop. This is +only a loop in the control flow through the op tree; it does not have +the heavyweight loop structure that allows exiting the loop by C<last> +and suchlike. I<flags> gives the eight bits of C<op_flags> for the +top-level op, except that some bits will be set automatically as required. +I<expr> supplies the expression controlling loop iteration, and I<block> +supplies the body of the loop; they are consumed by this function and +become part of the constructed op tree. I<debuggable> is currently +unused and should always be 1. + +=cut +*/ + +OP * +Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) +{ + OP* listop; + OP* o; + const bool once = block && block->op_flags & OPf_SPECIAL && + block->op_type == OP_NULL; + + PERL_UNUSED_ARG(debuggable); + + if (expr) { + 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 + || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + 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 ? OpSIBLING(k1) : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1 && (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + || k1->op_type == OP_EACH + || k1->op_type == OP_AEACH)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } + } + } + + /* if block is null, the next op_append_elem() would put UNSTACK, a scalar + * op, in listop. This is wrong. [perl #27024] */ + if (!block) + block = newOP(OP_NULL, 0); + 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 */ + + o->op_flags |= flags; + o = op_scope(o); + o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + return o; +} + +/* +=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my + +Constructs, checks, and returns an op tree expressing a C<while> loop. +This is a heavyweight loop, with structure that allows exiting the loop +by C<last> and suchlike. + +I<loop> is an optional preconstructed C<enterloop> op to use in the +loop; if it is null then a suitable op will be constructed automatically. +I<expr> supplies the loop's controlling expression. I<block> supplies the +main body of the loop, and I<cont> optionally supplies a C<continue> block +that operates as a second half of the body. All of these optree inputs +are consumed by this function and become part of the constructed op tree. + +I<flags> gives the eight bits of C<op_flags> for the C<leaveloop> +op and, shifted up eight bits, the eight bits of C<op_private> for +the C<leaveloop> op, except that (in both cases) some bits will be set +automatically. I<debuggable> is currently unused and should always be 1. +I<has_my> can be supplied as true to force the +loop body to be enclosed in its own scope. + +=cut +*/ + +OP * +Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, + OP *expr, OP *block, OP *cont, I32 has_my) +{ + dVAR; + OP *redo; + OP *next = NULL; + OP *listop; + OP *o; + U8 loopflags = 0; + + PERL_UNUSED_ARG(debuggable); + + if (expr) { + if (expr->op_type == OP_READLINE + || expr->op_type == OP_READDIR + || expr->op_type == OP_GLOB + || expr->op_type == OP_EACH || expr->op_type == OP_AEACH + || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { + expr = newUNOP(OP_DEFINED, 0, + 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) ? OpSIBLING(k1) : NULL; + switch (expr->op_type) { + case OP_NULL: + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + + case OP_SASSIGN: + if (k1 && (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) + || k1->op_type == OP_EACH + || k1->op_type == OP_AEACH)) + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } + } + } + + if (!block) + block = newOP(OP_NULL, 0); + else if (cont || has_my) { + block = op_scope(block); + } + + if (cont) { + next = LINKLIST(cont); + } + if (expr) { + OP * const unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = op_append_elem(OP_LINESEQ, cont, unstack); + } + + assert(block); + listop = op_append_list(OP_LINESEQ, block, cont); + assert(listop); + redo = LINKLIST(listop); + + if (expr) { + scalar(listop); + o = new_logop(OP_AND, 0, &expr, &listop); + if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { + op_free((OP*)loop); + return expr; /* listop already freed by new_logop */ + } + if (listop) + ((LISTOP*)listop)->op_last->op_next = + (o == listop ? redo : LINKLIST(o)); + } + else + o = listop; + + if (!loop) { + NewOp(1101,loop,1,LOOP); + OpTYPE_set(loop, OP_ENTERLOOP); + loop->op_private = 0; + loop->op_next = (OP*)loop; + } + + o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); + + loop->op_redoop = redo; + loop->op_lastop = o; + o->op_private |= loopflags; + + if (next) + loop->op_nextop = next; + else + loop->op_nextop = o; + + o->op_flags |= flags; + o->op_private |= (flags >> 8); + return o; +} + +/* +=for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont + +Constructs, checks, and returns an op tree expressing a C<foreach> +loop (iteration through a list of values). This is a heavyweight loop, +with structure that allows exiting the loop by C<last> and suchlike. + +I<sv> optionally supplies the variable that will be aliased to each +item in turn; if null, it defaults to C<$_> (either lexical or global). +I<expr> supplies the list of values to iterate over. I<block> supplies +the main body of the loop, and I<cont> optionally supplies a C<continue> +block that operates as a second half of the body. All of these optree +inputs are consumed by this function and become part of the constructed +op tree. + +I<flags> gives the eight bits of C<op_flags> for the C<leaveloop> +op and, shifted up eight bits, the eight bits of C<op_private> for +the C<leaveloop> op, except that (in both cases) some bits will be set +automatically. + +=cut +*/ + +OP * +Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) +{ + dVAR; + LOOP *loop; + OP *wop; + PADOFFSET padoff = 0; + I32 iterflags = 0; + I32 iterpflags = 0; + + PERL_ARGS_ASSERT_NEWFOROP; + + if (sv) { + if (sv->op_type == OP_RV2SV) { /* symbol table variable */ + iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ + OpTYPE_set(sv, OP_RV2GV); + + /* The op_type check is needed to prevent a possible segfault + * if the loop variable is undeclared and 'strict vars' is in + * effect. This is illegal but is nonetheless parsed, so we + * may reach this point with an OP_CONST where we're expecting + * an OP_GV. + */ + if (cUNOPx(sv)->op_first->op_type == OP_GV + && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) + iterpflags |= OPpITER_DEF; + } + else if (sv->op_type == OP_PADSV) { /* private variable */ + iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ + padoff = sv->op_targ; + sv->op_targ = 0; + op_free(sv); + sv = NULL; + PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); + } + else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) + NOOP; + else + Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); + if (padoff) { + PADNAME * const pn = PAD_COMPNAME(padoff); + const char * const name = PadnamePV(pn); + + if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_') + iterpflags |= OPpITER_DEF; + } + } + else { + const PADOFFSET offset = pad_findmy_pvs("$_", 0); + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { + sv = newGVOP(OP_GV, 0, PL_defgv); + } + else { + padoff = offset; + } + iterpflags |= OPpITER_DEF; + } + + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); + iterflags |= OPf_STACKED; + } + else if (expr->op_type == OP_NULL && + (expr->op_flags & OPf_KIDS) && + ((BINOP*)expr)->op_first->op_type == OP_FLOP) + { + /* Basically turn for($x..$y) into the same as for($x,$y), but we + * set the STACKED flag to indicate that these values are to be + * treated as min/max values by 'pp_enteriter'. + */ + 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 = OpSIBLING(left); + LISTOP* listop; + + range->op_flags &= ~OPf_KIDS; + /* 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; + left->op_next = range->op_other; + right->op_next = (OP*)listop; + listop->op_next = listop->op_first; + + op_free(expr); + expr = (OP*)(listop); + op_null(expr); + iterflags |= OPf_STACKED; + } + else { + expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); + } + + loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags, + op_append_elem(OP_LIST, list(expr), + scalar(sv))); + assert(!loop->op_next); + /* for my $x () sets OPpLVAL_INTRO; + * for our $x () sets OPpOUR_INTRO */ + loop->op_private = (U8)iterpflags; + if (loop->op_slabbed + && DIFF(loop, OpSLOT(loop)->opslot_next) + < SIZE_TO_PSIZE(sizeof(LOOP))) + { + LOOP *tmp; + NewOp(1234,tmp,1,LOOP); + Copy(loop,tmp,1,LISTOP); +#ifdef PERL_OP_PARENT + assert(loop->op_last->op_sibparent == (OP*)loop); + OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */ +#endif + S_op_destroy(aTHX_ (OP*)loop); + loop = tmp; + } + else if (!loop->op_slabbed) + { + loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); +#ifdef PERL_OP_PARENT + OpLASTSIB_set(loop->op_last, (OP*)loop); +#endif + } + loop->op_targ = padoff; + wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); + return wop; +} + +/* +=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label + +Constructs, checks, and returns a loop-exiting op (such as C<goto> +or C<last>). I<type> is the opcode. I<label> supplies the parameter +determining the target of the op; it is consumed by this function and +becomes part of the constructed op tree. + +=cut +*/ + +OP* +Perl_newLOOPEX(pTHX_ I32 type, OP *label) +{ + OP *o = NULL; + + PERL_ARGS_ASSERT_NEWLOOPEX; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_CUSTOM); + + if (type != OP_GOTO) { + /* "last()" means "last" */ + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { + o = newOP(type, OPf_SPECIAL); + } + } + else { + /* Check whether it's going to be a goto &function */ + if (label->op_type == OP_ENTERSUB + && !(label->op_flags & OPf_STACKED)) + label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); + } + + /* Check for a constant argument */ + if (label->op_type == OP_CONST) { + SV * const sv = ((SVOP *)label)->op_sv; + STRLEN l; + const char *s = SvPV_const(sv,l); + if (l == strlen(s)) { + o = newPVOP(type, + SvUTF8(((SVOP*)label)->op_sv), + savesharedpv( + SvPV_nolen_const(((SVOP*)label)->op_sv))); + } + } + + /* If we have already created an op, we do not need the label. */ + if (o) + op_free(label); + else o = newUNOP(type, OPf_STACKED, label); + + PL_hints |= HINT_BLOCK_SCOPE; + return o; +} + +/* if the condition is a literal array or hash + (or @{ ... } etc), make a reference to it. + */ +STATIC OP * +S_ref_array_or_hash(pTHX_ OP *cond) +{ + if (cond + && (cond->op_type == OP_RV2AV + || cond->op_type == OP_PADAV + || cond->op_type == OP_RV2HV + || cond->op_type == OP_PADHV)) + + return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); + + else if(cond + && (cond->op_type == OP_ASLICE + || 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 */ + cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF); + cond->op_flags |= OPf_WANT_LIST; + + return newANONLIST(op_lvalue(cond, OP_ANONLIST)); + } + + else + return cond; +} + +/* These construct the optree fragments representing given() + and when() blocks. + + entergiven and enterwhen are LOGOPs; the op_other pointer + points up to the associated leave op. We need this so we + can put it in the context and make break/continue work. + (Also, of course, pp_enterwhen will jump straight to + op_other if the match fails.) + */ + +STATIC OP * +S_newGIVWHENOP(pTHX_ OP *cond, OP *block, + I32 enter_opcode, I32 leave_opcode, + PADOFFSET entertarg) +{ + dVAR; + LOGOP *enterop; + OP *o; + + PERL_ARGS_ASSERT_NEWGIVWHENOP; + + enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); + enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); + enterop->op_private = 0; + + o = newUNOP(leave_opcode, 0, (OP *) enterop); + + if (cond) { + /* 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_flags |= OPf_SPECIAL; + o ->op_flags |= OPf_SPECIAL; + + o->op_next = (OP *) enterop; + } + + CHECKOP(enter_opcode, enterop); /* Currently does nothing, since + entergiven and enterwhen both + use ck_null() */ + + enterop->op_next = LINKLIST(block); + block->op_next = enterop->op_other = o; + + return o; +} + +/* Does this look like a boolean operation? For these purposes + a boolean operation is: + - a subroutine call [*] + - a logical connective + - a comparison operator + - a filetest operator, with the exception of -s -M -A -C + - defined(), exists() or eof() + - /$re/ or $foo =~ /$re/ + + [*] possibly surprising + */ +STATIC bool +S_looks_like_bool(pTHX_ const OP *o) +{ + PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; + + switch(o->op_type) { + case OP_OR: + case OP_DOR: + return looks_like_bool(cLOGOPo->op_first); + + case OP_AND: + { + OP* sibl = OpSIBLING(cLOGOPo->op_first); + ASSUME(sibl); + return ( + looks_like_bool(cLOGOPo->op_first) + && looks_like_bool(sibl)); + } + + case OP_NULL: + case OP_SCALAR: + return ( + o->op_flags & OPf_KIDS + && looks_like_bool(cUNOPo->op_first)); + + case OP_ENTERSUB: + + case OP_NOT: case OP_XOR: + + case OP_EQ: case OP_NE: case OP_LT: + case OP_GT: case OP_LE: case OP_GE: + + case OP_I_EQ: case OP_I_NE: case OP_I_LT: + case OP_I_GT: case OP_I_LE: case OP_I_GE: + + case OP_SEQ: case OP_SNE: case OP_SLT: + case OP_SGT: case OP_SLE: case OP_SGE: + + case OP_SMARTMATCH: + + case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: + case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: + case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: + case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: + case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: + case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: + case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: + case OP_FTTEXT: case OP_FTBINARY: + + case OP_DEFINED: case OP_EXISTS: + case OP_MATCH: case OP_EOF: + + case OP_FLOP: + + return TRUE; + + case OP_CONST: + /* Detect comparisons that have been optimized away */ + if (cSVOPo->op_sv == &PL_sv_yes + || cSVOPo->op_sv == &PL_sv_no) + + return TRUE; + else + return FALSE; + + /* FALLTHROUGH */ + default: + return FALSE; + } +} + +/* +=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off + +Constructs, checks, and returns an op tree expressing a C<given> block. +I<cond> supplies the expression that will be locally assigned to a lexical +variable, and I<block> supplies the body of the C<given> construct; they +are consumed by this function and become part of the constructed op tree. +I<defsv_off> is the pad offset of the scalar lexical variable that will +be affected. If it is 0, the global $_ will be used. + +=cut +*/ + +OP * +Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) +{ + PERL_ARGS_ASSERT_NEWGIVENOP; + return newGIVWHENOP( + ref_array_or_hash(cond), + block, + OP_ENTERGIVEN, OP_LEAVEGIVEN, + defsv_off); +} + +/* +=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block + +Constructs, checks, and returns an op tree expressing a C<when> block. +I<cond> supplies the test expression, and I<block> supplies the block +that will be executed if the test evaluates to true; they are consumed +by this function and become part of the constructed op tree. I<cond> +will be interpreted DWIMically, often as a comparison against C<$_>, +and may be null to generate a C<default> block. + +=cut +*/ + +OP * +Perl_newWHENOP(pTHX_ OP *cond, OP *block) +{ + const bool cond_llb = (!cond || looks_like_bool(cond)); + OP *cond_op; + + PERL_ARGS_ASSERT_NEWWHENOP; + + if (cond_llb) + cond_op = cond; + else { + cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, + newDEFSVOP(), + scalar(ref_array_or_hash(cond))); + } + + 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) + ? 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; + + if (p == NULL && cvp == NULL) + return; + + if (!ckWARN_d(WARN_PROTOTYPE)) + return; + + if (p && cvp) { + p = S_strip_spaces(aTHX_ p, &plen); + cvp = S_strip_spaces(aTHX_ cvp, &clen); + if ((flags & SVf_UTF8) == SvUTF8(cv)) { + if (plen == clen && memEQ(cvp, p, plen)) + return; + } else { + if (flags & SVf_UTF8) { + if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) + return; + } + else { + if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) + return; + } + } + } + + msg = sv_newmortal(); + + if (gv) + { + if (isGV(gv)) + 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:"); + if (name) + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); + if (cvp) + Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")", + UTF8fARG(SvUTF8(cv),clen,cvp) + ); + else + sv_catpvs(msg, ": none"); + sv_catpvs(msg, " vs "); + if (p) + Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p)); + else + sv_catpvs(msg, "none"); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); +} + +static void const_sv_xsub(pTHX_ CV* cv); +static void const_av_xsub(pTHX_ CV* cv); + +/* + +=head1 Optree Manipulation Functions + +=for apidoc cv_const_sv + +If C<cv> 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<newCONSTSUB> or as described in +L<perlsub/"Constant Functions">. + +=cut +*/ +SV * +Perl_cv_const_sv(const CV *const cv) +{ + SV *sv; + if (!cv) + return NULL; + if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) + return NULL; + sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; + if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; + return sv; +} + +SV * +Perl_cv_const_sv_or_av(const CV * const cv) +{ + 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 2 ways: + * + * !allow_lex + * look for a single OP_CONST with attached value: return the value + * + * allow_lex && !CvCONST(cv); + * + * examine the clone prototype, and if contains only a single + * OP_CONST, return the value; or if it contains a single PADSV ref- + * erencing an outer lexical, turn on CvCONST to indicate the CV is + * a candidate for "constizing" at clone time, and return NULL. + */ + +static SV * +S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex) +{ + SV *sv = NULL; + bool padsv = FALSE; + + assert(o); + assert(cv); + + for (; o; o = o->op_next) { + const OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_LINESEQ + || type == OP_NULL + || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + if (type == OP_LEAVESUB) + break; + if (sv) + 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 (allow_lex && type == OP_PADSV) { + if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) + { + sv = &PL_sv_undef; /* an arbitrary non-null value */ + padsv = TRUE; + } + else + return NULL; + } + else { + return NULL; + } + } + if (padsv) { + CvCONST_on(cv); + return NULL; + } + return sv; +} + +static bool +S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, + PADNAME * const name, SV ** const const_svp) +{ + assert (cv); + assert (o || name); + assert (const_svp); + if ((!block + )) { + if (CvFLAGS(PL_compcv)) { + /* might have had built-in attrs applied */ + const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); + if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl + && ckWARN(WARN_MISC)) + { + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); + SvREFCNT_inc_simple_void_NN(PL_compcv); + } + CvFLAGS(cv) |= + (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS + & ~(CVf_LVALUE * pureperl)); + } + return FALSE; + } + + /* redundant check for speed: */ + if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + SV *namesv = o + ? cSVOPo->op_sv + : sv_2mortal(newSVpvn_utf8( + PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) + )); + 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); + report_redefined_cv(namesv, cv, const_svp); + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + } + SAVEFREESV(cv); + return TRUE; +} + +CV * +Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) +{ + CV **spot; + SV **svspot; + const char *ps; + STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ + U32 ps_utf8 = 0; + CV *cv = NULL; + CV *compcv = PL_compcv; + SV *const_sv; + PADNAME *name; + PADOFFSET pax = o->op_targ; + CV *outcv = CvOUTSIDE(PL_compcv); + CV *clonee = NULL; + HEK *hek = NULL; + bool reusable = FALSE; + OP *start = NULL; +#ifdef PERL_DEBUG_READONLY_OPS + OPSLAB *slab = NULL; +#endif + + PERL_ARGS_ASSERT_NEWMYSUB; + + /* Find the pad slot for storing the new sub. + We cannot use PL_comppad, as it is the pad owned by the new sub. We + need to look in CvOUTSIDE and find the pad belonging to the enclos- + ing sub. And then we need to dig deeper if this is a lexical from + outside, as in: + my sub foo; sub { sub foo { } } + */ + redo: + name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax]; + if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) { + pax = PARENT_PAD_INDEX(name); + outcv = CvOUTSIDE(outcv); + assert(outcv); + goto redo; + } + svspot = + &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) + [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; + spot = (CV **)svspot; + + if (!(PL_parser && PL_parser->error_count)) + move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name)); + + 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 (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); + + if (PL_parser && PL_parser->error_count) { + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = 0; + goto done; + } + + if (CvDEPTH(outcv) && CvCLONE(compcv)) { + cv = *spot; + svspot = (SV **)(spot = &clonee); + } + else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) + cv = *spot; + else { + assert (SvTYPE(*spot) == SVt_PVCV); + 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), + hash + ) + ); + CvLEXICAL_on(*spot); + } + cv = PadnamePROTOCV(name); + svspot = (SV **)(spot = &PadnamePROTOCV(name)); + } + + if (block) { + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(scalarseq(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + start = LINKLIST(block); + block->op_next = 0; + } + + if (!block || !ps || *ps || attrs + || CvLVALUE(compcv) + ) + const_sv = NULL; + else + const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); + + if (cv) { + const bool exists = CvROOT(cv) || CvXSUB(cv); + + /* if the subroutine doesn't exist and wasn't pre-declared + * with a prototype, assume it will be AUTOLOADed, + * skipping the prototype check + */ + if (exists || SvPOK(cv)) + cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len, + ps_utf8); + /* already defined? */ + if (exists) { + if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv)) + cv = NULL; + else { + if (attrs) goto attrs; + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(compcv); + goto done; + } + } + else if (CvDEPTH(outcv) && CvCLONE(compcv)) { + cv = NULL; + reusable = TRUE; + } + } + if (const_sv) { + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); + } + else { + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + *spot = cv; + } + sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(compcv); + op_free(block); + SvREFCNT_dec(compcv); + PL_compcv = NULL; + goto setname; + } + /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to + determine whether this sub definition is in the same scope as its + declaration. If this sub definition is inside an inner named pack- + age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to + the package sub. So check PadnameOUTER(name) too. + */ + if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { + assert(!CvWEAKOUTSIDE(compcv)); + SvREFCNT_dec(CvOUTSIDE(compcv)); + CvWEAKOUTSIDE_on(compcv); + } + /* XXX else do we have a circular reference? */ + if (cv) { /* must reuse cv in case stub is referenced elsewhere */ + /* transfer PL_compcv to cv */ + if (block + ) { + cv_flags_t preserved_flags = + CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); + PADLIST *const temp_padl = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + SvPOK_off(cv); + CvFLAGS(cv) = + CvFLAGS(compcv) | preserved_flags; + CvOUTSIDE(cv) = CvOUTSIDE(compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); + CvPADLIST_set(cv, CvPADLIST(compcv)); + CvOUTSIDE(compcv) = temp_cv; + CvPADLIST_set(compcv, temp_padl); + CvSTART(cv) = CvSTART(compcv); + CvSTART(compcv) = cvstart; + CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(compcv) |= other_flags; + + if (CvFILE(cv) && CvDYNFILE(cv)) { + Safefree(CvFILE(cv)); + } + + /* inner references to compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(compcv); + PL_compcv = compcv = cv; + } + else { + cv = compcv; + *spot = cv; + } + setname: + CvLEXICAL_on(cv); + if (!CvNAME_HEK(cv)) { + 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), + hash); + } + CvNAME_HEK_set(cv, hek); + } + if (const_sv) goto clone; + + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + + if (ps) { + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); + } + + if (!block) + goto attrs; + + /* If we assign an optree to a PVCV, then we've defined a subroutine that + the debugger could be able to set a breakpoint in, so signal to + pp_entereval that it should not throw away any saved lines at scope + exit. */ + + PL_breakable_sub_gen++; + CvROOT(cv) = block; + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); + /* The cv no longer needs to hold a refcount on the slab, as CvROOT + itself has a refcount. */ + CvSLABBED_off(cv); + OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); +#ifdef PERL_DEBUG_READONLY_OPS + slab = (OPSLAB *)CvSTART(cv); +#endif + CvSTART(cv) = start; + CALL_PEEP(start); + finalize_optree(CvROOT(cv)); + S_prune_chain_head(&CvSTART(cv)); + + /* now that optimizer has done its work, adjust pad values */ + + pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + + attrs: + if (attrs) { + /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ + apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); + } + + if (block) { + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = sv_newmortal(); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + if (HvNAME_HEK(PL_curstash)) { + sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); + sv_catpvs(tmpstr, "::"); + } + else sv_setpvs(tmpstr, "__ANON__::"); + sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, + PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); + (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), + SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } + } + + clone: + if (clonee) { + assert(CvDEPTH(outcv)); + spot = (CV **) + &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; + if (reusable) cv_clone_into(clonee, *spot); + else *spot = cv_clone(clonee); + SvREFCNT_dec_NN(clonee); + cv = *spot; + } + if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { + PADOFFSET depth = CvDEPTH(outcv); + while (--depth) { + SV *oldcv; + svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; + oldcv = *svspot; + *svspot = SvREFCNT_inc_simple_NN(cv); + SvREFCNT_dec(oldcv); + } + } + + done: + if (PL_parser) + PL_parser->copline = NOLINE; + LEAVE_SCOPE(floor); +#ifdef PERL_DEBUG_READONLY_OPS + if (slab) + Slab_to_ro(slab); +#endif + op_free(o); + return cv; +} + +/* _x = extended */ +CV * +Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, bool o_is_gv) +{ + GV *gv; + const char *ps; + STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ + U32 ps_utf8 = 0; + CV *cv = NULL; + SV *const_sv; + const bool ec = PL_parser && PL_parser->error_count; + /* 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 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)) + ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; + STRLEN namlen = 0; + 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); + bool evanescent = FALSE; + OP *start = NULL; +#ifdef PERL_DEBUG_READONLY_OPS + OPSLAB *slab = NULL; +#endif + + if (o_is_gv) { + gv = (GV*)o; + o = NULL; + has_name = TRUE; + } else if (name) { + /* 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_NOTQUAL; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); + has_name = TRUE; + } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { + SV * const sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", + PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; + } else if (PL_curstash) { + gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; + } else { + 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 (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); + if (name) SvREFCNT_dec(PL_compcv); + else cv = PL_compcv; + PL_compcv = 0; + if (name && block) { + const char *s = strrchr(name, ':'); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + if (PL_in_eval & EVAL_KEEPERR) + Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); + else { + SV * const errsv = ERRSV; + /* force display of errors found but not reported */ + sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); + Perl_croak_nocontext("%"SVf, SVfARG(errsv)); + } + } + } + goto done; + } + + 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 (!SvROK(gv)) { + if (ps) { + sv_setpvn(MUTABLE_SV(gv), ps, ps_len); + if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); + } + else + sv_setiv(MUTABLE_SV(gv), -1); + } + + SvREFCNT_dec(PL_compcv); + cv = PL_compcv = NULL; + goto done; + } + } + + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + + if (block) { + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(PL_compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) + && (!isGV(gv) || !GvASSUMECV(gv))) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(scalarseq(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + start = LINKLIST(block); + block->op_next = 0; + } + + if (!block || !ps || *ps || attrs + || CvLVALUE(PL_compcv) + ) + const_sv = NULL; + else + const_sv = + S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv))); + + if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { + 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); + + /* if the subroutine doesn't exist and wasn't pre-declared + * with a prototype, assume it will be AUTOLOADed, + * skipping the prototype check + */ + if (exists || SvPOK(cv)) + cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); + /* already defined (or promised)? */ + if (exists || (isGV(gv) && GvASSUMECV(gv))) { + if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) + cv = NULL; + else { + if (attrs) goto attrs; + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(PL_compcv); + goto done; + } + } + } + if (const_sv) { + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); + sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + else { + if (isGV(gv) || CvMETHOD(PL_compcv)) { + if (name && isGV(gv)) + GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + 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); + } + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + goto done; + } + if (cv) { /* must reuse cv if autoloaded */ + /* transfer PL_compcv to cv */ + if (block + ) { + cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; + PADLIST *const temp_av = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + 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 + | CvNAMED(cv); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvPADLIST_set(cv,CvPADLIST(PL_compcv)); + CvOUTSIDE(PL_compcv) = temp_cv; + CvPADLIST_set(PL_compcv, temp_av); + CvSTART(cv) = CvSTART(PL_compcv); + CvSTART(PL_compcv) = cvstart; + CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(PL_compcv) |= other_flags; + + if (CvFILE(cv) && CvDYNFILE(cv)) { + Safefree(CvFILE(cv)); + } + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(PL_compcv); + PL_compcv = cv; + } + else { + cv = PL_compcv; + 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 (!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); + } + + if (ps) { + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); + } + + if (!block) + goto attrs; + + /* If we assign an optree to a PVCV, then we've defined a subroutine that + the debugger could be able to set a breakpoint in, so signal to + pp_entereval that it should not throw away any saved lines at scope + exit. */ + + PL_breakable_sub_gen++; + CvROOT(cv) = block; + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); + /* The cv no longer needs to hold a refcount on the slab, as CvROOT + itself has a refcount. */ + CvSLABBED_off(cv); + OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv)); +#ifdef PERL_DEBUG_READONLY_OPS + slab = (OPSLAB *)CvSTART(cv); +#endif + CvSTART(cv) = start; + CALL_PEEP(start); + finalize_optree(CvROOT(cv)); + S_prune_chain_head(&CvSTART(cv)); + + /* now that optimizer has done its work, adjust pad values */ + + pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + + attrs: + if (attrs) { + /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ + 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); + } + + if (block && has_name) { + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = cv_name(cv,NULL,0); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), + SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } + + if (name) { + if (PL_parser && PL_parser->error_count) + clear_special_blocks(name, gv, cv); + else + evanescent = + process_special_blocks(floor, name, gv, cv); + } + } + + done: + if (PL_parser) + PL_parser->copline = NOLINE; + LEAVE_SCOPE(floor); + if (!evanescent) { +#ifdef PERL_DEBUG_READONLY_OPS + if (slab) + Slab_to_ro(slab); +#endif + if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv))) + pad_add_weakref(cv); + } + 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)); + } +} + +/* Returns true if the sub has been freed. */ +STATIC bool +S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, + GV *const gv, + CV *const cv) +{ + const char *const colon = strrchr(fullname,':'); + const char *const name = colon ? colon + 1 : fullname; + + PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; + + 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); + + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); + GvCV_set(gv,0); /* cv has been hijacked */ + call_list(oldscope, PL_beginav); + + POPSTACK; + LEAVE; + return !PL_savebegin; + } + else + 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 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 FALSE; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else + return FALSE; + DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); + GvCV_set(gv,0); /* cv has been hijacked */ + return FALSE; + } +} + +/* +=for apidoc newCONSTSUB + +See L</newCONSTSUB_flags>. + +=cut +*/ + +CV * +Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) +{ + return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv); +} + +/* +=for apidoc newCONSTSUB_flags + +Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is +eligible for inlining at compile-time. + +Currently, the only useful value for C<flags> is SVf_UTF8. + +The newly created subroutine takes ownership of a reference to the passed in +SV. + +Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>, +which won't be called if used as a destructor, but will suppress the overhead +of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at +compile time.) + +=cut +*/ + +CV * +Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, + U32 flags, SV *sv) +{ + CV* cv; + const char *const file = CopFILE(PL_curcop); + + ENTER; + + if (IN_PERL_RUNTIME) { + /* at runtime, it's not safe to manipulate PL_curcop: it may be + * an op shared between threads. Use a non-shared COP for our + * dirty work */ + SAVEVPTR(PL_curcop); + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + PL_curcop = &PL_compiling; + } + SAVECOPLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); + + SAVEHINTS(); + PL_hints &= ~HINT_BLOCK_SCOPE; + + if (stash) { + SAVEGENERICSV(PL_curstash); + PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); + } + + /* Protect sv against leakage caused by fatal warnings. */ + if (sv) SAVEFREESV(sv); + + /* file becomes the CvFILE. For an XS, it's usually static storage, + and so doesn't get free()d. (It's expected to be from the C pre- + processor __FILE__ directive). But we need a dynamically allocated one, + and we need it to get freed. */ + cv = newXS_len_flags(name, len, + sv && SvTYPE(sv) == SVt_PVAV + ? const_av_xsub + : const_sv_xsub, + file ? file : "", "", + &sv, XS_DYNAMIC_FILENAME | flags); + CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); + CvCONST_on(cv); + + LEAVE; + + return cv; +} + +/* +=for apidoc U||newXS + +Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be +static storage, as it is used directly as CvFILE(), without a copy being made. + +=cut +*/ + +CV * +Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) +{ + PERL_ARGS_ASSERT_NEWXS; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 + ); +} + +CV * +Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, + const char *const filename, const char *const proto, + U32 flags) +{ + PERL_ARGS_ASSERT_NEWXS_FLAGS; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags + ); +} + +CV * +Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr) +{ + PERL_ARGS_ASSERT_NEWXS_DEFFILE; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0 + ); +} + +CV * +Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, + XSUBADDR_t subaddr, const char *const filename, + const char *const proto, SV **const_svp, + U32 flags) +{ + CV *cv; + bool interleave = FALSE; + + PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; + + { + GV * const gv = gv_fetchpvn( + name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + name ? len : PL_curstash ? sizeof("__ANON__") - 1: + sizeof("__ANON__::__ANON__") - 1, + GV_ADDMULTI | flags, SVt_PVCV); + + if ((cv = (name ? GvCV(gv) : NULL))) { + if (GvCVGEN(gv)) { + /* just a cached method */ + SvREFCNT_dec(cv); + cv = NULL; + } + else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { + /* already defined (or promised) */ + /* Redundant check that allows us to avoid creating an SV + most of the time: */ + if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { + report_redefined_cv(newSVpvn_flags( + name,len,(flags&SVf_UTF8)|SVs_TEMP + ), + cv, const_svp); + } + interleave = TRUE; + ENTER; + SAVEFREESV(cv); + cv = NULL; + } + } + + if (cv) /* must reuse cv if autoloaded */ + cv_undef(cv); + else { + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + if (name) { + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + if (HvENAME_HEK(GvSTASH(gv))) + gv_method_changed(gv); /* newXS */ + } + } + + CvGV_set(cv, gv); + if(filename) { + (void)gv_fetchfile(filename); + assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */ + if (flags & XS_DYNAMIC_FILENAME) { + CvDYNFILE_on(cv); + CvFILE(cv) = savepv(filename); + } else { + /* NOTE: not copied, as it is expected to be an external constant string */ + CvFILE(cv) = (char *)filename; + } + } else { + assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename); + CvFILE(cv) = (char*)PL_xsubfilename; + } + CvISXSUB_on(cv); + CvXSUB(cv) = subaddr; +#ifndef PERL_IMPLICIT_CONTEXT + CvHSCXT(cv) = &PL_stack_sp; +#else + PoisonPADLIST(cv); +#endif + + if (name) + process_special_blocks(0, name, gv, cv); + else + CvANON_on(cv); + } /* <- not a conditional branch */ + + + sv_setpv(MUTABLE_SV(cv), proto); + if (interleave) LEAVE; + return cv; +} + +CV * +Perl_newSTUB(pTHX_ GV *gv, bool fake) +{ + CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GV *cvgv; + PERL_ARGS_ASSERT_NEWSTUB; + assert(!GvCVu(gv)); + GvCV_set(gv, cv); + GvCVGEN(gv) = 0; + if (!fake && HvENAME_HEK(GvSTASH(gv))) + gv_method_changed(gv); + if (SvFAKE(gv)) { + cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); + SvFAKE_off(cvgv); + } + else cvgv = gv; + CvGV_set(cv, cvgv); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + GvMULTI_on(gv); + return cv; +} + +void +Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) +{ + CV *cv; + + GV *gv; + + if (PL_parser && PL_parser->error_count) { + op_free(block); + goto finish; + } + + gv = o + ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) + : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); + + GvMULTI_on(gv); + if ((cv = GvFORM(gv))) { + if (ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } else { + /* diag_listed_as: Format %s redefined */ + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); + } + cv = PL_compcv; + GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); + CvGV_set(cv, gv); + CvFILE_set_from_cop(cv, PL_curcop); + + + pad_tidy(padtidy_FORMAT); + CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); + CvSTART(cv) = LINKLIST(CvROOT(cv)); + CvROOT(cv)->op_next = 0; + CALL_PEEP(CvSTART(cv)); + finalize_optree(CvROOT(cv)); + S_prune_chain_head(&CvSTART(cv)); + cv_forget_slab(cv); + + finish: + op_free(o); + if (PL_parser) + PL_parser->copline = NOLINE; + LEAVE_SCOPE(floor); + PL_compiling.cop_seq = 0; +} + +OP * +Perl_newANONLIST(pTHX_ OP *o) +{ + return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o); +} + +OP * +Perl_newANONHASH(pTHX_ OP *o) +{ + return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o); +} + +OP * +Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block) +{ + return newANONATTRSUB(floor, proto, NULL, block); +} + +OP * +Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) +{ + SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); + OP * anoncode = + newSVOP(OP_ANONCODE, 0, + cv); + if (CvANONCONST(cv)) + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); + return newUNOP(OP_REFGEN, 0, anoncode); +} + +OP * +Perl_oopsAV(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_OOPSAV; + + switch (o->op_type) { + case OP_PADSV: + case OP_PADHV: + OpTYPE_set(o, OP_PADAV); + return ref(o, OP_RV2AV); + + case OP_RV2SV: + case OP_RV2HV: + OpTYPE_set(o, OP_RV2AV); + ref(o, OP_RV2AV); + break; + + default: + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); + break; + } + return o; +} + +OP * +Perl_oopsHV(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_OOPSHV; + + switch (o->op_type) { + case OP_PADSV: + case OP_PADAV: + OpTYPE_set(o, OP_PADHV); + return ref(o, OP_RV2HV); + + case OP_RV2SV: + case OP_RV2AV: + OpTYPE_set(o, OP_RV2HV); + ref(o, OP_RV2HV); + break; + + default: + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); + break; + } + return o; +} + +OP * +Perl_newAVREF(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_NEWAVREF; + + if (o->op_type == OP_PADANY) { + OpTYPE_set(o, OP_PADAV); + return o; + } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { + Perl_croak(aTHX_ "Can't use an array as a reference"); + } + return newUNOP(OP_RV2AV, 0, scalar(o)); +} + +OP * +Perl_newGVREF(pTHX_ I32 type, OP *o) +{ + if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) + return newUNOP(OP_NULL, 0, o); + return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); +} + +OP * +Perl_newHVREF(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_NEWHVREF; + + if (o->op_type == OP_PADANY) { + OpTYPE_set(o, OP_PADHV); + return o; + } + else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { + Perl_croak(aTHX_ "Can't use a hash as a reference"); + } + return newUNOP(OP_RV2HV, 0, scalar(o)); +} + +OP * +Perl_newCVREF(pTHX_ I32 flags, OP *o) +{ + if (o->op_type == OP_PADANY) { + dVAR; + OpTYPE_set(o, OP_PADCV); + } + return newUNOP(OP_RV2CV, flags, scalar(o)); +} + +OP * +Perl_newSVREF(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_NEWSVREF; + + if (o->op_type == OP_PADANY) { + OpTYPE_set(o, OP_PADSV); + scalar(o); + return o; + } + return newUNOP(OP_RV2SV, 0, scalar(o)); +} + +/* Check routines. See the comments at the top of this file for details + * on when these are called */ + +OP * +Perl_ck_anoncode(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_ANONCODE; + + cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type); + 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_backtick(pTHX_ OP *o) +{ + 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 = OpSIBLING(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); + + if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR + || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR + || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND + || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT) + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE), + "The bitwise feature is experimental"); + if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ + && OP_IS_INFIX_BIT(o->op_type)) + { + const OP * const left = cBINOPo->op_first; + const OP * const right = OpSIBLING(left); + if ((OP_IS_NUMCOMPARE(left->op_type) && + (left->op_flags & OPf_PARENS) == 0) || + (OP_IS_NUMCOMPARE(right->op_type) && + (right->op_flags & OPf_PARENS) == 0)) + Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %s operator", + o->op_type == OP_BIT_OR + ||o->op_type == OP_NBIT_OR ? "|" + : o->op_type == OP_BIT_AND + ||o->op_type == OP_NBIT_AND ? "&" + : o->op_type == OP_BIT_XOR + ||o->op_type == OP_NBIT_XOR ? "^" + : o->op_type == OP_SBIT_OR ? "|." + : o->op_type == OP_SBIT_AND ? "&." : "^." + ); + } + return o; +} + +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 + && strEQ(GvNAME(cGVOPx_gv(kid)), "["); +} + +OP * +Perl_ck_cmp(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_CMP; + if (ckWARN(WARN_SYNTAX)) { + const OP *kid = cUNOPo->op_first; + if (kid && + ( + ( is_dollar_bracket(aTHX_ kid) + && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST + ) + || ( kid->op_type == OP_CONST + && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) + ) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "$[ used in %s (did you mean $] ?)", OP_DESC(o)); + } + return o; +} + +OP * +Perl_ck_concat(pTHX_ OP *o) +{ + const OP * const kid = cUNOPo->op_first; + + PERL_ARGS_ASSERT_CK_CONCAT; + PERL_UNUSED_CONTEXT; + + if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && + !(kUNOP->op_first->op_flags & OPf_MOD)) + o->op_flags |= OPf_STACKED; + return o; +} + +OP * +Perl_ck_spair(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_CK_SPAIR; + + 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; + kidkid = kUNOP->op_first; + newop = OpSIBLING(kidkid); + if (newop) { + const OPCODE type = newop->op_type; + if (OpHAS_SIBLING(newop)) + return o; + if (o->op_type == OP_REFGEN + && ( type == OP_RV2CV + || ( !(newop->op_flags & OPf_PARENS) + && ( type == OP_RV2AV || type == OP_PADAV + || type == OP_RV2HV || type == OP_PADHV)))) + NOOP; /* OK (allow srefgen for \@a and \%h) */ + else if (OP_GIMME(newop,0) != G_SCALAR) + return o; + } + /* 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 */ + o->op_ppaddr = PL_ppaddr[++o->op_type]; + return ck_fun(o); +} + +OP * +Perl_ck_delete(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_DELETE; + + o = ck_fun(o); + o->op_private = 0; + if (o->op_flags & OPf_KIDS) { + OP * const kid = cUNOPo->op_first; + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALLTHROUGH */ + case OP_HSLICE: + o->op_private |= OPpSLICE; + break; + case OP_AELEM: + o->op_flags |= OPf_SPECIAL; + /* 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_ "delete argument is not a HASH or ARRAY " + "element or slice"); + } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; + op_null(kid); + } + return o; +} + +OP * +Perl_ck_eof(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_EOF; + + if (o->op_flags & OPf_KIDS) { + OP *kid; + if (cLISTOPo->op_first->op_type == OP_STUB) { + OP * const newop + = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + o = newop; + } + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) + kid->op_private |= OPpALLOW_FAKE; + } + return o; +} + +OP * +Perl_ck_eval(pTHX_ OP *o) +{ + dVAR; + + PERL_ARGS_ASSERT_CK_EVAL; + + PL_hints |= HINT_BLOCK_SCOPE; + if (o->op_flags & OPf_KIDS) { + SVOP * const kid = (SVOP*)cUNOPo->op_first; + assert(kid); + + if (o->op_type == OP_ENTERTRY) { + LOGOP *enter; + + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); + op_free(o); + + enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL); + + /* establish postfix order */ + enter->op_next = (OP*)enter; + + o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); + OpTYPE_set(o, OP_LEAVETRY); + enter->op_other = o; + return o; + } + else { + scalar((OP*)kid); + S_set_haseval(aTHX); + } + } + else { + const U8 priv = o->op_private; + op_free(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; + if ((PL_hints & HINT_LOCALIZE_HH) != 0 + && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { + /* Store a copy of %^H that pp_entereval can pick up. */ + OP *hhop = newSVOP(OP_HINTSEVAL, 0, + MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); + /* 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) + && FEATURE_UNIEVAL_IS_ENABLED) + o->op_private |= OPpEVAL_UNICODE; + return o; +} + +OP * +Perl_ck_exec(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_EXEC; + + if (o->op_flags & OPf_STACKED) { + OP *kid; + o = ck_fun(o); + kid = OpSIBLING(cUNOPo->op_first); + if (kid->op_type == OP_RV2GV) + op_null(kid); + } + else + o = listkids(o); + return o; +} + +OP * +Perl_ck_exists(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_EXISTS; + + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP * const kid = cUNOPo->op_first; + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV + && !(PL_parser && PL_parser->error_count)) + 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_ "exists argument is not a HASH or ARRAY " + "element or a subroutine"); + op_null(kid); + } + return o; +} + +OP * +Perl_ck_rvconst(pTHX_ OP *o) +{ + dVAR; + SVOP * const kid = (SVOP*)cUNOPo->op_first; + + PERL_ARGS_ASSERT_CK_RVCONST; + + o->op_private |= (PL_hints & HINT_STRICT_REFS); + + if (kid->op_type == OP_CONST) { + int iscv; + GV *gv; + SV * const kidsv = kid->op_sv; + + /* Is it a constant from cv_const_sv()? */ + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { + return o; + } + if (SvTYPE(kidsv) == SVt_PVAV) return o; + if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + const char *badthing; + switch (o->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + default: + badthing = NULL; + break; + } + if (badthing) + Perl_croak(aTHX_ + "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + SVfARG(kidsv), badthing); + } + /* + * This is a little tricky. We only want to add the symbol if we + * didn't add it in the lexer. Otherwise we get duplicate strict + * warnings. But if we didn't add it in the lexer, we must at + * least pretend like we wanted to add it even if it existed before, + * 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 ? 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 + ? SVt_PV + : o->op_type == OP_RV2AV + ? SVt_PVAV + : o->op_type == OP_RV2HV + ? SVt_PVHV + : SVt_PVGV); + 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); + } + OpTYPE_set(kid, OP_GV); + SvREFCNT_dec(kid->op_sv); +#ifdef USE_ITHREADS + /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ + STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); + PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); +#else + kid->op_sv = SvREFCNT_inc_simple_NN(gv); +#endif + kid->op_private = 0; + /* FAKE globs in the symbol table cause weird bugs (#77810) */ + SvFAKE_off(gv); + } + } + return o; +} + +OP * +Perl_ck_ftst(pTHX_ OP *o) +{ + dVAR; + const I32 type = o->op_type; + + PERL_ARGS_ASSERT_CK_FTST; + + if (o->op_flags & OPf_REF) { + NOOP; + } + else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { + SVOP * const kid = (SVOP*)cUNOPo->op_first; + const OPCODE kidtype = kid->op_type; + + if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) + && !kid->op_folded) { + OP * const newop = newGVOP(type, OPf_REF, + gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); + op_free(o); + return newop; + } + if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) + o->op_private |= OPpFT_ACCESS; + if (type != OP_STAT && type != OP_LSTAT + && PL_check[kidtype] == Perl_ck_ftst + && kidtype != OP_STAT && kidtype != OP_LSTAT + ) { + o->op_private |= OPpFT_STACKED; + kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; + } + } + else { + op_free(o); + if (type == OP_FTTTY) + o = newGVOP(type, OPf_REF, PL_stdingv); + else + o = newUNOP(type, 0, newDEFSVOP()); + } + return o; +} + +OP * +Perl_ck_fun(pTHX_ OP *o) +{ + const int type = o->op_type; + I32 oa = PL_opargs[type] >> OASHIFT; + + PERL_ARGS_ASSERT_CK_FUN; + + if (o->op_flags & OPf_STACKED) { + if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) + oa &= ~OA_OPTIONAL; + else + return no_fh_allowed(o); + } + + if (o->op_flags & OPf_KIDS) { + OP *prev_kid = NULL; + OP *kid = cLISTOPo->op_first; + I32 numargs = 0; + bool seen_optional = FALSE; + + if (kid->op_type == OP_PUSHMARK || + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) + { + prev_kid = kid; + kid = OpSIBLING(kid); + } + if (kid && kid->op_type == OP_COREARGS) { + bool optional = FALSE; + while (oa) { + numargs++; + if (oa & OA_OPTIONAL) optional = TRUE; + oa = oa >> 4; + } + if (optional) o->op_private |= numargs; + return o; + } + + while (oa) { + if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { + 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++; + switch (oa & 7) { + case OA_SCALAR: + /* list seen where single (scalar) arg expected? */ + if (numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST && type != OP_SCALAR) + { + return too_many_arguments_pv(o,PL_op_desc[type], 0); + } + if (type != OP_DELETE) scalar(kid); + break; + case OA_LIST: + if (oa < 16) { + kid = 0; + continue; + } + else + list(kid); + break; + case OA_AVREF: + if ((type == OP_PUSH || type == OP_UNSHIFT) + && !OpHAS_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 + && ( !SvROK(cSVOPx_sv(kid)) + || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) + ) + bad_type_pv(numargs, "array", o, kid); + /* 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); + /* 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_RV2HV && kid->op_type != OP_PADHV) + bad_type_pv(numargs, "hash", o, kid); + op_lvalue(kid, type); + break; + case OA_CVREF: + { + /* 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; + } + break; + case OA_FILEREF: + if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { + if (kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { + OP * const newop = newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); + /* replace kid with newop in chain */ + op_sibling_splice(o, prev_kid, 1, newop); + op_free(kid); + kid = newop; + } + else if (kid->op_type == OP_READLINE) { + /* neophyte patrol: open(<FH>), close(<FH>) etc. */ + bad_type_pv(numargs, "HANDLE", o, kid); + } + else { + I32 flags = OPf_SPECIAL; + I32 priv = 0; + PADOFFSET targ = 0; + + /* is this op a FH constructor? */ + if (is_handle_constructor(o,numargs)) { + const char *name = NULL; + STRLEN len = 0; + U32 name_utf8 = 0; + bool want_dollar = TRUE; + + flags = 0; + /* Set a flag to tell rv2gv to vivify + * need to "prove" flag does not mean something + * else already - NI-S 1999/05/07 + */ + priv = OPpDEREF; + if (kid->op_type == OP_PADSV) { + PADNAME * const pn + = PAD_COMPNAME_SV(kid->op_targ); + name = PadnamePV (pn); + len = PadnameLEN(pn); + name_utf8 = PadnameUTF8(pn); + } + else if (kid->op_type == OP_RV2SV + && kUNOP->op_first->op_type == OP_GV) + { + GV * const gv = cGVOPx_gv(kUNOP->op_first); + name = GvNAME(gv); + len = GvNAMELEN(gv); + name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0; + } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + OP *firstop; + OP *op = ((BINOP*)kid)->op_first; + name = NULL; + if (op) { + SV *tmpstr = NULL; + const char * const a = + kid->op_type == OP_AELEM ? + "[]" : "{}"; + if (((op->op_type == OP_RV2AV) || + (op->op_type == OP_RV2HV)) && + (firstop = ((UNOP*)op)->op_first) && + (firstop->op_type == OP_GV)) { + /* packagevar $a[] or $h{} */ + GV * const gv = cGVOPx_gv(firstop); + if (gv) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + GvNAME(gv), + a[0], a[1]); + } + else if (op->op_type == OP_PADAV + || op->op_type == OP_PADHV) { + /* lexicalvar $a[] or $h{} */ + const char * const padname = + PAD_COMPNAME_PV(op->op_targ); + if (padname) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + padname + 1, + a[0], a[1]); + } + if (tmpstr) { + name = SvPV_const(tmpstr, len); + name_utf8 = SvUTF8(tmpstr); + sv_2mortal(tmpstr); + } + } + if (!name) { + name = "__ANONIO__"; + len = 10; + want_dollar = FALSE; + } + op_lvalue(kid, type); + } + if (name) { + SV *namesv; + targ = pad_alloc(OP_RV2GV, SVf_READONLY); + namesv = PAD_SVl(targ); + if (want_dollar && *name != '$') + sv_setpvs(namesv, "$"); + else + sv_setpvs(namesv, ""); + sv_catpvn(namesv, name, len); + if ( name_utf8 ) SvUTF8_on(namesv); + } + } + scalar(kid); + kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, + OP_RV2GV, flags); + kid->op_targ = targ; + kid->op_private |= priv; + } + } + scalar(kid); + break; + case OA_SCALARREF: + if ((type == OP_UNDEF || type == OP_POS) + && numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST) + return too_many_arguments_pv(o,PL_op_desc[type], 0); + op_lvalue(scalar(kid), type); + break; + } + oa >>= 4; + prev_kid = kid; + kid = OpSIBLING(kid); + } + /* 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); + listkids(o); + } + else if (PL_opargs[type] & OA_DEFGV) { + /* Ordering of these two is important to keep f_map.t passing. */ + op_free(o); + return newUNOP(type, 0, newDEFSVOP()); + } + + if (oa) { + while (oa & OA_OPTIONAL) + oa >>= 4; + if (oa && oa != OA_LIST) + return too_few_arguments_pv(o,OP_DESC(o), 0); + } + return o; +} + +OP * +Perl_ck_glob(pTHX_ OP *o) +{ + GV *gv; + + PERL_ARGS_ASSERT_CK_GLOB; + + o = ck_fun(o); + if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first)) + op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ + + if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) + { + /* convert + * glob + * \ null - const(wildcard) + * into + * null + * \ enter + * \ list + * \ mark - glob - rv2cv + * | \ gv(CORE::GLOBAL::glob) + * | + * \ null - const(wildcard) + */ + o->op_flags |= OPf_SPECIAL; + o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); + 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; + } + else o->op_flags &= ~OPf_SPECIAL; +#if !defined(PERL_EXTERNAL_GLOB) + if (!PL_globhook) { + ENTER; + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs("File::Glob"), NULL, NULL, NULL); + LEAVE; + } +#endif /* !PERL_EXTERNAL_GLOB */ + gv = (GV *)newSV(0); + gv_init(gv, 0, "", 0, 0); + gv_IOadd(gv); + op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); + SvREFCNT_dec_NN(gv); /* newGVOP increased it */ + scalarkids(o); + return o; +} + +OP * +Perl_ck_grep(pTHX_ OP *o) +{ + LOGOP *gwop; + OP *kid; + const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; + PADOFFSET offset; + + PERL_ARGS_ASSERT_CK_GREP; + + /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ + + if (o->op_flags & OPf_STACKED) { + kid = cUNOPx(OpSIBLING(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 = OpSIBLING(cLISTOPo->op_first); + if (type == OP_MAPWHILE) + list(kid); + else + scalar(kid); + o = ck_fun(o); + if (PL_parser && PL_parser->error_count) + return o; + kid = OpSIBLING(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; + + gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); + kid->op_next = (OP*)gwop; + offset = pad_findmy_pvs("$_", 0); + if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { + o->op_private = gwop->op_private = 0; + gwop->op_targ = pad_alloc(type, SVs_PADTMP); + } + else { + o->op_private = gwop->op_private = OPpGREP_LEX; + gwop->op_targ = o->op_targ = offset; + } + + kid = OpSIBLING(cLISTOPo->op_first); + for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) + op_lvalue(kid, OP_GREPSTART); + + return (OP*)gwop; +} + +OP * +Perl_ck_index(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_INDEX; + + if (o->op_flags & OPf_KIDS) { + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid) + kid = OpSIBLING(kid); /* get past "big" */ + if (kid && kid->op_type == OP_CONST) { + const bool save_taint = TAINT_get; + SV *sv = kSVOP->op_sv; + if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) { + sv = newSV(0); + sv_copypv(sv, kSVOP->op_sv); + SvREFCNT_dec_NN(kSVOP->op_sv); + kSVOP->op_sv = sv; + } + if (SvOK(sv)) fbm_compile(sv, 0); + TAINT_set(save_taint); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_VAR(save_taint); +#endif + } + } + return ck_fun(o); +} + +OP * +Perl_ck_lfun(pTHX_ OP *o) +{ + const OPCODE type = o->op_type; + + PERL_ARGS_ASSERT_CK_LFUN; + + return modkids(ck_fun(o), type); +} + +OP * +Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ +{ + PERL_ARGS_ASSERT_CK_DEFINED; + + if ((o->op_flags & OPf_KIDS)) { + switch (cUNOPo->op_first->op_type) { + case OP_RV2AV: + case OP_PADAV: + Perl_croak(aTHX_ "Can't use 'defined(@array)'" + " (Maybe you should just omit the defined()?)"); + break; + case OP_RV2HV: + case OP_PADHV: + Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" + " (Maybe you should just omit the defined()?)"); + break; + default: + /* no warning */ + break; + } + } + return ck_rfun(o); +} + +OP * +Perl_ck_readline(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_READLINE; + + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + else { + OP * const newop + = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + return newop; + } + return o; +} + +OP * +Perl_ck_rfun(pTHX_ OP *o) +{ + const OPCODE type = o->op_type; + + PERL_ARGS_ASSERT_CK_RFUN; + + return refkids(ck_fun(o), type); +} + +OP * +Perl_ck_listiob(pTHX_ OP *o) +{ + OP *kid; + + PERL_ARGS_ASSERT_CK_LISTIOB; + + kid = cLISTOPo->op_first; + if (!kid) { + o = force_list(o, 1); + kid = cLISTOPo->op_first; + } + if (kid->op_type == OP_PUSHMARK) + kid = OpSIBLING(kid); + if (kid && o->op_flags & OPf_STACKED) + kid = OpSIBLING(kid); + else if (kid && !OpHAS_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 */ + 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 = OpSIBLING(kid); + } + } + + if (!kid) + op_append_elem(o->op_type, o, newDEFSVOP()); + + if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); + return listkids(o); +} + +OP * +Perl_ck_smartmatch(pTHX_ OP *o) +{ + dVAR; + PERL_ARGS_ASSERT_CK_SMARTMATCH; + if (0 == (o->op_flags & OPf_SPECIAL)) { + OP *first = cBINOPo->op_first; + OP *second = OpSIBLING(first); + + /* Implicitly take a reference to an array or hash */ + + /* 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) { + OpTYPE_set(first, OP_QR); + } + if (second->op_type == OP_MATCH) { + OpTYPE_set(second, OP_QR); + } + } + + return o; +} + + +static OP * +S_maybe_targlex(pTHX_ OP *o) +{ + OP * const kid = cLISTOPo->op_first; + /* has a disposable target? */ + if ((PL_opargs[kid->op_type] & OA_TARGLEX) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY) + ) + { + OP * const kkid = OpSIBLING(kid); + + /* Can just relocate the target. */ + if (kkid && kkid->op_type == OP_PADSV + && (!(kkid->op_private & OPpLVAL_INTRO) + || kkid->op_private & OPpPAD_STATE)) + { + kid->op_targ = kkid->op_targ; + kkid->op_targ = 0; + /* Now we do not need PADSV and SASSIGN. + * Detach kid and free the rest. */ + op_sibling_splice(o, NULL, 1, NULL); + op_free(o); + kid->op_private |= OPpTARGET_MY; /* Used for context settings */ + return kid; + } + } + return o; +} + +OP * +Perl_ck_sassign(pTHX_ OP *o) +{ + dVAR; + OP * const kid = cLISTOPo->op_first; + + PERL_ARGS_ASSERT_CK_SASSIGN; + + if (OpHAS_SIBLING(kid)) { + OP *kkid = OpSIBLING(kid); + /* For state variable assignment with attributes, kkid is a list op + whose op_last is a padsv. */ + if ((kkid->op_type == OP_PADSV || + (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && + (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV + ) + ) + && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == (OPpLVAL_INTRO|OPpPAD_STATE)) { + const PADOFFSET target = kkid->op_targ; + OP *const other = newOP(OP_PADSV, + kkid->op_flags + | ((kkid->op_private & ~OPpLVAL_INTRO) << 8)); + OP *const first = newOP(OP_NULL, 0); + OP *const nullop = + newCONDOP(0, first, o, other); + /* XXX targlex disabled for now; see ticket #124160 + newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other); + */ + OP *const condop = first->op_next; + + OpTYPE_set(condop, OP_ONCE); + other->op_targ = target; + nullop->op_flags |= OPf_WANT_SCALAR; + + /* Store the initializedness of state vars in a separate + pad entry. */ + condop->op_targ = + pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0); + /* hijacking PADSTALE for uninitialized state variables */ + SvPADSTALE_on(PAD_SVl(condop->op_targ)); + + return nullop; + } + } + return S_maybe_targlex(aTHX_ o); +} + +OP * +Perl_ck_match(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_MATCH; + + if (o->op_type != OP_QR && PL_compcv) { + const PADOFFSET offset = pad_findmy_pvs("$_", 0); + if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { + o->op_targ = offset; + o->op_private |= OPpTARGET_MY; + } + } + if (o->op_type == OP_MATCH || o->op_type == OP_QR) + o->op_private |= OPpRUNTIME; + return o; +} + +OP * +Perl_ck_method(pTHX_ OP *o) +{ + SV *sv, *methsv, *rclass; + const char* method; + char* compatptr; + int utf8; + STRLEN len, nsplit = 0, i; + OP* new_op; + OP * const kid = cUNOPo->op_first; + + PERL_ARGS_ASSERT_CK_METHOD; + if (kid->op_type != OP_CONST) return o; + + sv = kSVOP->op_sv; + + /* replace ' with :: */ + while ((compatptr = strchr(SvPVX(sv), '\''))) { + *compatptr = ':'; + sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1); + } + + method = SvPVX_const(sv); + len = SvCUR(sv); + utf8 = SvUTF8(sv) ? -1 : 1; + + for (i = len - 1; i > 0; --i) if (method[i] == ':') { + nsplit = i+1; + break; + } + + methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0); + + if (!nsplit) { /* $proto->method() */ + op_free(o); + return newMETHOP_named(OP_METHOD_NAMED, 0, methsv); + } + + if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */ + op_free(o); + return newMETHOP_named(OP_METHOD_SUPER, 0, methsv); + } + + /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */ + if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) { + rclass = newSVpvn_share(method, utf8*(nsplit-9), 0); + new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv); + } else { + rclass = newSVpvn_share(method, utf8*(nsplit-2), 0); + new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv); + } +#ifdef USE_ITHREADS + op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ); +#else + cMETHOPx(new_op)->op_rclass_sv = rclass; +#endif + op_free(o); + return new_op; +} + +OP * +Perl_ck_null(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_NULL; + PERL_UNUSED_CONTEXT; + return o; +} + +OP * +Perl_ck_open(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_OPEN; + + S_io_hints(aTHX_ o); + { + /* In case of three-arg dup open remove strictness + * from the last arg if it is a bareword. */ + OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ + OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ + OP *oa; + const char *mode; + + if ((last->op_type == OP_CONST) && /* The bareword. */ + (last->op_private & OPpCONST_BARE) && + (last->op_private & OPpCONST_STRICT) && + (oa = OpSIBLING(first)) && /* The fh. */ + (oa = OpSIBLING(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 == OpSIBLING(oa))) /* The bareword. */ + last->op_private &= ~OPpCONST_STRICT; + } + return ck_fun(o); +} + +OP * +Perl_ck_prototype(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_PROTOTYPE; + if (!(o->op_flags & OPf_KIDS)) { + op_free(o); + return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); + } + return o; +} + +OP * +Perl_ck_refassign(pTHX_ OP *o) +{ + OP * const right = cLISTOPo->op_first; + OP * const left = OpSIBLING(right); + OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first; + bool stacked = 0; + + PERL_ARGS_ASSERT_CK_REFASSIGN; + assert (left); + assert (left->op_type == OP_SREFGEN); + + o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE); + + switch (varop->op_type) { + case OP_PADAV: + o->op_private |= OPpLVREF_AV; + goto settarg; + case OP_PADHV: + o->op_private |= OPpLVREF_HV; + case OP_PADSV: + settarg: + o->op_targ = varop->op_targ; + varop->op_targ = 0; + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; + case OP_RV2AV: + o->op_private |= OPpLVREF_AV; + goto checkgv; + NOT_REACHED; /* NOTREACHED */ + case OP_RV2HV: + o->op_private |= OPpLVREF_HV; + /* FALLTHROUGH */ + case OP_RV2SV: + checkgv: + if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; + detach_and_stack: + /* Point varop to its GV kid, detached. */ + varop = op_sibling_splice(varop, NULL, -1, NULL); + stacked = TRUE; + break; + case OP_RV2CV: { + OP * const kidparent = + OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); + OP * const kid = cUNOPx(kidparent)->op_first; + o->op_private |= OPpLVREF_CV; + if (kid->op_type == OP_GV) { + varop = kidparent; + goto detach_and_stack; + } + if (kid->op_type != OP_PADCV) goto bad; + o->op_targ = kid->op_targ; + kid->op_targ = 0; + break; + } + case OP_AELEM: + case OP_HELEM: + o->op_private |= OPpLVREF_ELEM; + op_null(varop); + stacked = TRUE; + /* Detach varop. */ + op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); + break; + default: + bad: + /* diag_listed_as: Can't modify reference to %s in %s assignment */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " + "assignment", + OP_DESC(varop))); + return o; + } + if (!FEATURE_REFALIASING_IS_ENABLED) + Perl_croak(aTHX_ + "Experimental aliasing via reference not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__REFALIASING), + "Aliasing via reference is experimental"); + if (stacked) { + o->op_flags |= OPf_STACKED; + op_sibling_splice(o, right, 1, varop); + } + else { + o->op_flags &=~ OPf_STACKED; + op_sibling_splice(o, right, 1, NULL); + } + op_free(left); + return o; +} + +OP * +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; + kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */ + kids = force_list(kids, 1); /* promote it to a list */ + op_sibling_splice(o, NULL, 0, kids); /* and add back */ + } + else + scalar(o); + return o; +} + +OP * +Perl_ck_require(pTHX_ OP *o) +{ + 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; + 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) { + SvREADONLY_off(sv); + } + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); + + s = SvPVX(sv); + len = SvCUR(sv); + end = s + len; + for (; s < end; s++) { + if (*s == ':' && s[1] == ':') { + *s = '/'; + Move(s+2, s+1, end - s - 1, char); + --end; + } + } + 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) + && !SvVOK(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 */ + /* handle override, if any */ + && (gv = gv_override("require", 7))) { + OP *kid, *newop; + if (o->op_flags & OPf_KIDS) { + kid = cUNOPo->op_first; + op_sibling_splice(o, NULL, -1, NULL); + } + else { + kid = newDEFSVOP(); + } + op_free(o); + newop = S_new_entersubop(aTHX_ gv, kid); + return newop; + } + + return ck_fun(o); +} + +OP * +Perl_ck_return(pTHX_ OP *o) +{ + OP *kid; + + PERL_ARGS_ASSERT_CK_RETURN; + + kid = OpSIBLING(cLISTOPo->op_first); + if (CvLVALUE(PL_compcv)) { + for (; kid; kid = OpSIBLING(kid)) + op_lvalue(kid, OP_LEAVESUBLV); + } + + return o; +} + +OP * +Perl_ck_select(pTHX_ OP *o) +{ + dVAR; + OP* kid; + + PERL_ARGS_ASSERT_CK_SELECT; + + if (o->op_flags & OPf_KIDS) { + kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && OpHAS_SIBLING(kid)) { + OpTYPE_set(o, OP_SSELECT); + o = ck_fun(o); + return fold_constants(op_integerize(op_std_init(o))); + } + } + o = ck_fun(o); + kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && kid->op_type == OP_RV2GV) + kid->op_private &= ~HINT_STRICT_REFS; + return o; +} + +OP * +Perl_ck_shift(pTHX_ OP *o) +{ + const I32 type = o->op_type; + + PERL_ARGS_ASSERT_CK_SHIFT; + + if (!(o->op_flags & OPf_KIDS)) { + OP *argop; + + if (!CvUNIQUE(PL_compcv)) { + o->op_flags |= OPf_SPECIAL; + return o; + } + + argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); + op_free(o); + return newUNOP(type, 0, scalar(argop)); + } + return scalar(ck_fun(o)); +} + +OP * +Perl_ck_sort(pTHX_ OP *o) +{ + OP *firstkid; + OP *kid; + HV * const hinthv = + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; + U8 stacked; + + PERL_ARGS_ASSERT_CK_SORT; + + if (hinthv) { + SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); + if (svp) { + const I32 sorthints = (I32)SvIV(*svp); + if ((sorthints & HINT_SORT_QUICKSORT) != 0) + o->op_private |= OPpSORT_QSORT; + if ((sorthints & HINT_SORT_STABLE) != 0) + o->op_private |= OPpSORT_STABLE; + } + } + + if (o->op_flags & OPf_STACKED) + simplify_sort(o); + firstkid = OpSIBLING(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) + op_null(kid); /* wipe out leave */ + /* Prevent execution from escaping out of the sort block. */ + kid->op_next = 0; + + /* provide scalar context for comparison function/block */ + kid = scalar(firstkid); + 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; + /* replace the const op with the pad op */ + op_sibling_splice(firstkid, NULL, 1, padop); + op_free(kid); + } + } + } + + firstkid = OpSIBLING(firstkid); + } + + for (kid = firstkid; kid; kid = OpSIBLING(kid)) { + /* provide list context for arguments */ + list(kid); + if (stacked) + op_lvalue(kid, OP_GREPSTART); + } + + 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) +{ + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + OP *k; + int descending; + GV *gv; + const char *gvname; + bool have_scopeop; + + PERL_ARGS_ASSERT_SIMPLIFY_SORT; + + kid = kUNOP->op_first; /* get past null */ + if (!(have_scopeop = kid->op_type == OP_SCOPE) + && kid->op_type != OP_LEAVE) + return; + kid = kLISTOP->op_last; /* get past scope */ + switch(kid->op_type) { + case OP_NCMP: + case OP_I_NCMP: + case OP_SCMP: + if (!have_scopeop) goto padkids; + break; + default: + return; + } + k = kid; /* remember this node*/ + if (kBINOP->op_first->op_type != OP_RV2SV + || kBINOP->op_last ->op_type != OP_RV2SV) + { + /* + Warn about my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ + + padkids: + if (!ckWARN(WARN_SYNTAX)) return; + kid = kBINOP->op_first; + do { + if (kid->op_type == OP_PADSV) { + PADNAME * const name = PAD_COMPNAME(kid->op_targ); + if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' + && ( PadnamePV(name)[1] == 'a' + || PadnamePV(name)[1] == 'b' )) + /* diag_listed_as: "my %s" used in sort comparison */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\"%s %s\" used in sort comparison", + PadnameIsSTATE(name) + ? "state" + : "my", + PadnamePV(name)); + } + } while ((kid = OpSIBLING(kid))); + return; + } + kid = kBINOP->op_first; /* get past cmp */ + if (kUNOP->op_first->op_type != OP_GV) + return; + kid = kUNOP->op_first; /* get past rv2sv */ + gv = kGVOP_gv; + if (GvSTASH(gv) != PL_curstash) + return; + gvname = GvNAME(gv); + if (*gvname == 'a' && gvname[1] == '\0') + descending = 0; + else if (*gvname == 'b' && gvname[1] == '\0') + descending = 1; + else + return; + + kid = k; /* back to cmp */ + /* already checked above that it is rv2sv */ + kid = kBINOP->op_last; /* down to 2nd arg */ + if (kUNOP->op_first->op_type != OP_GV) + return; + kid = kUNOP->op_first; /* get past rv2sv */ + gv = kGVOP_gv; + if (GvSTASH(gv) != PL_curstash) + return; + gvname = GvNAME(gv); + if ( descending + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) + return; + o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); + if (descending) + o->op_private |= OPpSORT_DESCEND; + if (k->op_type == OP_NCMP) + o->op_private |= OPpSORT_NUMERIC; + if (k->op_type == OP_I_NCMP) + o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; + kid = OpSIBLING(cLISTOPo->op_first); + /* cut out and delete old block (second sibling) */ + op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); + op_free(kid); +} + +OP * +Perl_ck_split(pTHX_ OP *o) +{ + dVAR; + OP *kid; + + PERL_ARGS_ASSERT_CK_SPLIT; + + if (o->op_flags & OPf_STACKED) + return no_fh_allowed(o); + + kid = cLISTOPo->op_first; + if (kid->op_type != OP_NULL) + Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); + /* delete leading NULL node, then add a CONST if no other nodes */ + op_sibling_splice(o, NULL, 1, + OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); + op_free(kid); + kid = cLISTOPo->op_first; + + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { + /* remove kid, and replace with new optree */ + op_sibling_splice(o, NULL, 1, NULL); + /* OPf_SPECIAL is used to trigger split " " behavior */ + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0); + op_sibling_splice(o, NULL, 0, kid); + } + OpTYPE_set(kid, OP_PUSHRE); + /* target implies @ary=..., so wipe it */ + kid->op_targ = 0; + scalar(kid); + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /g modifier is meaningless in split"); + } + + if (!OpHAS_SIBLING(kid)) + op_append_elem(OP_SPLIT, o, newDEFSVOP()); + + kid = OpSIBLING(kid); + assert(kid); + scalar(kid); + + if (!OpHAS_SIBLING(kid)) + { + op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); + o->op_private |= OPpSPLIT_IMPLIM; + } + assert(OpHAS_SIBLING(kid)); + + kid = OpSIBLING(kid); + scalar(kid); + + if (OpHAS_SIBLING(kid)) + return too_many_arguments_pv(o,OP_DESC(o), 0); + + return o; +} + +OP * +Perl_ck_stringify(pTHX_ OP *o) +{ + OP * const kid = OpSIBLING(cUNOPo->op_first); + PERL_ARGS_ASSERT_CK_STRINGIFY; + if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA + || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST + || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) + && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ + { + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + op_free(o); + return kid; + } + return ck_fun(o); +} + +OP * +Perl_ck_join(pTHX_ OP *o) +{ + OP * const kid = OpSIBLING(cLISTOPo->op_first); + + PERL_ARGS_ASSERT_CK_JOIN; + + if (kid && kid->op_type == OP_MATCH) { + if (ckWARN(WARN_SYNTAX)) { + const REGEXP *re = PM_GETRE(kPMOP); + const SV *msg = re + ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), + SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) + : newSVpvs_flags( "STRING", SVs_TEMP ); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "/%"SVf"/ should probably be written as \"%"SVf"\"", + SVfARG(msg), SVfARG(msg)); + } + } + if (kid + && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */ + || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) + || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV + && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) + { + const OP * const bairn = OpSIBLING(kid); /* the list */ + if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ + && OP_GIMME(bairn,0) == G_SCALAR) + { + OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, + op_sibling_splice(o, kid, 1, NULL)); + op_free(o); + return ret; + } + } + + return ck_fun(o); +} + +/* +=for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags + +Examines an op, which is expected to identify a subroutine at runtime, +and attempts to determine at compile time which subroutine it identifies. +This is normally used during Perl compilation to determine whether +a prototype can be applied to a function call. I<cvop> is the op +being considered, normally an C<rv2cv> op. A pointer to the identified +subroutine is returned, if it could be determined statically, and a null +pointer is returned if it was not possible to determine statically. + +Currently, the subroutine can be identified statically if the RV that the +C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op. +A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is +suitable if the constant value must be an RV pointing to a CV. Details of +this process may change in future versions of Perl. If the C<rv2cv> op +has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify +the subroutine statically: this flag is used to suppress compile-time +magic on a subroutine call, forcing it to use default runtime behaviour. + +If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling +of a GV reference is modified. If a GV was examined and its CV slot was +found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set. +If the op is not optimised away, and the CV slot is later populated with +a subroutine having a prototype, that flag eventually triggers the warning +"called too early to check prototype". + +If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead +of returning a pointer to the subroutine it returns a pointer to the +GV giving the most appropriate name for the subroutine in this context. +Normally this is just the C<CvGV> of the subroutine, but for an anonymous +(C<CvANON>) subroutine that is referenced through a GV it will be the +referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned. +A null pointer is returned as usual if there is no statically-determinable +subroutine. + +=cut +*/ + +/* shared by toke.c:yylex */ +CV * +Perl_find_lexical_cv(pTHX_ PADOFFSET off) +{ + PADNAME *name = PAD_COMPNAME(off); + CV *compcv = PL_compcv; + while (PadnameOUTER(name)) { + assert(PARENT_PAD_INDEX(name)); + compcv = CvOUTSIDE(compcv); + name = PadlistNAMESARRAY(CvPADLIST(compcv)) + [off = PARENT_PAD_INDEX(name)]; + } + assert(!PadnameIsOUR(name)); + if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) { + return PadnamePROTOCV(name); + } + return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; +} + +CV * +Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) +{ + OP *rvop; + CV *cv; + GV *gv; + PERL_ARGS_ASSERT_RV2CV_OP_CV; + 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; + if (cvop->op_private & OPpENTERSUB_AMPER) + return NULL; + if (!(cvop->op_flags & OPf_KIDS)) + return NULL; + rvop = cUNOPx(cvop)->op_first; + 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) + rvop->op_private |= OPpEARLY_CV; + return NULL; + } + } break; + case OP_CONST: { + SV *rv = cSVOPx_sv(rvop); + if (!SvROK(rv)) + return NULL; + cv = (CV*)SvRV(rv); + gv = NULL; + } break; + case OP_PADCV: { + cv = find_lexical_cv(rvop->op_targ); + gv = NULL; + } break; + default: { + return NULL; + } NOT_REACHED; /* NOTREACHED */ + } + if (SvTYPE((SV*)cv) != SVt_PVCV) + return NULL; + 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 { + return cv; + } +} + +/* +=for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop + +Performs the default fixup of the arguments part of an C<entersub> +op tree. This consists of applying list context to each of the +argument ops. This is the standard treatment used on a call marked +with C<&>, or a method call, or a call through a subroutine reference, +or any other call where the callee can't be identified at compile time, +or a call where the callee has no prototype. + +=cut +*/ + +OP * +Perl_ck_entersub_args_list(pTHX_ OP *entersubop) +{ + OP *aop; + + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; + + aop = cUNOPx(entersubop)->op_first; + if (!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { + /* skip the extra attributes->import() call implicitly added in + * something like foo(my $x : bar) + */ + if ( aop->op_type == OP_ENTERSUB + && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID + ) + continue; + list(aop); + op_lvalue(aop, OP_ENTERSUB); + } + return entersubop; +} + +/* +=for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv + +Performs the fixup of the arguments part of an C<entersub> op tree +based on a subroutine prototype. This makes various modifications to +the argument ops, from applying context up to inserting C<refgen> ops, +and checking the number and syntactic types of arguments, as directed by +the prototype. This is the standard treatment used on a subroutine call, +not marked with C<&>, where the callee can be identified at compile time +and has a prototype. + +I<protosv> supplies the subroutine prototype to be applied to the call. +It may be a normal defined scalar, of which the string value will be used. +Alternatively, for convenience, it may be a subroutine object (a C<CV*> +that has been cast to C<SV*>) which has a prototype. The prototype +supplied, in whichever form, does not need to match the actual callee +referenced by the op tree. + +If the argument ops disagree with the prototype, for example by having +an unacceptable number of arguments, a valid op tree is returned anyway. +The error is reflected in the parser state, normally resulting in a single +exception at the top level of parsing which covers all the compilation +errors that occurred. In the error message, the callee is referred to +by the name defined by the I<namegv> parameter. + +=cut +*/ + +OP * +Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) +{ + STRLEN proto_len; + const char *proto, *proto_end; + OP *aop, *prev, *cvop, *parent; + int optional = 0; + I32 arg = 0; + I32 contextclass = 0; + const char *e = NULL; + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; + if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); + if (SvTYPE(protosv) == SVt_PVCV) + proto = CvPROTO(protosv), proto_len = CvPROTOLEN(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 (!OpHAS_SIBLING(aop)) { + parent = aop; + aop = cUNOPx(aop)->op_first; + } + prev = aop; + aop = OpSIBLING(aop); + for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; + while (aop != cvop) { + OP* o3 = aop; + + if (proto >= proto_end) + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } + + switch (*proto) { + case ';': + optional = 1; + proto++; + continue; + case '_': + /* _ must be at the end */ + if (proto[1] && !strchr(";@%", proto[1])) + goto oops; + /* FALLTHROUGH */ + case '$': + proto++; + arg++; + scalar(aop); + break; + case '%': + case '@': + list(aop); + arg++; + break; + case '&': + proto++; + arg++; + if ( o3->op_type != OP_UNDEF + && (o3->op_type != OP_SREFGEN + || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type + != OP_ANONCODE + && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type + != OP_RV2CV))) + bad_type_gv(arg, namegv, o3, + arg == 1 ? "block or sub {}" : "sub {}"); + break; + case '*': + /* '*' allows any scalar type, including bareword */ + proto++; + arg++; + if (o3->op_type == OP_RV2GV) + goto wrapref; /* autoconvert GLOB -> GLOBref */ + else if (o3->op_type == OP_CONST) + o3->op_private &= ~OPpCONST_STRICT; + scalar(aop); + break; + case '+': + proto++; + arg++; + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV || + o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV + ) { + goto wrapref; + } + scalar(aop); + break; + case '[': case ']': + goto oops; + + case '\\': + proto++; + arg++; + again: + switch (*proto++) { + case '[': + if (contextclass++ == 0) { + e = strchr(proto, ']'); + if (!e || e == proto) + goto oops; + } + else + goto oops; + goto again; + + case ']': + if (contextclass) { + const char *p = proto; + const char *const end = proto; + contextclass = 0; + while (*--p != '[') + /* \[$] accepts any scalar lvalue */ + if (*p == '$' + && Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, + Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); + } else + goto oops; + break; + case '*': + if (o3->op_type == OP_RV2GV) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "symbol"); + break; + case '&': + if (o3->op_type == OP_ENTERSUB + && !(o3->op_flags & OPf_STACKED)) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "subroutine"); + break; + case '$': + if (o3->op_type == OP_RV2SV || + o3->op_type == OP_PADSV || + o3->op_type == OP_HELEM || + o3->op_type == OP_AELEM) + goto wrapref; + if (!contextclass) { + /* \$ accepts any scalar lvalue */ + if (Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, "scalar"); + } + break; + case '@': + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "array"); + break; + case '%': + if (o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "hash"); + break; + wrapref: + aop = S_op_sibling_newUNOP(aTHX_ parent, prev, + OP_REFGEN, 0); + if (contextclass && e) { + proto = e + 1; + contextclass = 0; + } + break; + default: goto oops; + } + if (contextclass) + goto again; + break; + case ' ': + proto++; + continue; + default: + oops: { + Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, + SVfARG(cv_name((CV *)namegv, NULL, 0)), + SVfARG(protosv)); + } + } + + op_lvalue(aop, OP_ENTERSUB); + prev = aop; + aop = OpSIBLING(aop); + } + if (aop == cvop && *proto == '_') { + /* generate an access to $_ */ + op_sibling_splice(parent, prev, 0, newDEFSVOP()); + } + if (!optional && proto_end > proto && + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } + return entersubop; +} + +/* +=for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv + +Performs the fixup of the arguments part of an C<entersub> op tree either +based on a subroutine prototype or using default list-context processing. +This is the standard treatment used on a subroutine call, not marked +with C<&>, where the callee can be identified at compile time. + +I<protosv> supplies the subroutine prototype to be applied to the call, +or indicates that there is no prototype. It may be a normal scalar, +in which case if it is defined then the string value will be used +as a prototype, and if it is undefined then there is no prototype. +Alternatively, for convenience, it may be a subroutine object (a C<CV*> +that has been cast to C<SV*>), of which the prototype will be used if it +has one. The prototype (or lack thereof) supplied, in whichever form, +does not need to match the actual callee referenced by the op tree. + +If the argument ops disagree with the prototype, for example by having +an unacceptable number of arguments, a valid op tree is returned anyway. +The error is reflected in the parser state, normally resulting in a single +exception at the top level of parsing which covers all the compilation +errors that occurred. In the error message, the callee is referred to +by the name defined by the I<namegv> parameter. + +=cut +*/ + +OP * +Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, + GV *namegv, SV *protosv) +{ + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST; + if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) + return ck_entersub_args_proto(entersubop, namegv, protosv); + else + return ck_entersub_args_list(entersubop); +} + +OP * +Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) +{ + int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv); + OP *aop = cUNOPx(entersubop)->op_first; + + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; + + if (!opnum) { + OP *cvop; + if (!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + aop = OpSIBLING(aop); + for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; + if (aop != cvop) + (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); + + op_free(entersubop); + switch(GvNAME(namegv)[2]) { + case 'F': return newSVOP(OP_CONST, 0, + newSVpv(CopFILE(PL_curcop),0)); + case 'L': return newSVOP( + OP_CONST, 0, + Perl_newSVpvf(aTHX_ + "%"IVdf, (IV)CopLINE(PL_curcop) + ) + ); + case 'P': return newSVOP(OP_CONST, 0, + (PL_curstash + ? newSVhek(HvNAME_HEK(PL_curstash)) + : &PL_sv_undef + ) + ); + } + NOT_REACHED; /* NOTREACHED */ + } + else { + OP *prev, *cvop, *first, *parent; + U32 flags = 0; + + parent = entersubop; + if (!OpHAS_SIBLING(aop)) { + parent = aop; + aop = cUNOPx(aop)->op_first; + } + + first = prev = aop; + aop = OpSIBLING(aop); + /* find last sibling */ + for (cvop = aop; + OpHAS_SIBLING(cvop); + prev = cvop, cvop = OpSIBLING(cvop)) + ; + if (!(cvop->op_private & OPpENTERSUB_NOPAREN) + /* Usually, OPf_SPECIAL on an op with no args means that it had + * 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 + && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9)) + flags |= OPpEVAL_BYTES <<8; + + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_UNOP: + case OA_BASEOP_OR_UNOP: + case OA_FILESTATOP: + return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags); + case OA_BASEOP: + if (aop) { + (void)too_many_arguments_pv(aop, GvNAME(namegv), 0); + op_free(aop); + } + return opnum == OP_RUNCV + ? newPVOP(OP_RUNCV,0,NULL) + : newOP(opnum,0); + default: + return op_convert_list(opnum,0,aop); + } + } + NOT_REACHED; /* NOTREACHED */ + return entersubop; +} + +/* +=for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p + +Retrieves the function that will be used to fix up a call to I<cv>. +Specifically, the function is applied to an C<entersub> op tree for a +subroutine call, not marked with C<&>, where the callee can be identified +at compile time as I<cv>. + +The C-level function pointer is returned in I<*ckfun_p>, and an SV +argument for it is returned in I<*ckobj_p>. The function is intended +to be called in this manner: + + entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); + +In this call, I<entersubop> is a pointer to the C<entersub> op, +which may be replaced by the check function, and I<namegv> is a GV +supplying the name that should be used by the check function to refer +to the callee of the C<entersub> 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. + +By default, the function is +L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>, +and the SV parameter is I<cv> itself. This implements standard +prototype processing. It can be changed, for a particular subroutine, +by L</cv_set_call_checker>. + +=cut +*/ + +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) +{ + MAGIC *callmg; + 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_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<cv>. +Specifically, the function is applied to an C<entersub> op tree for a +subroutine call, not marked with C<&>, where the callee can be identified +at compile time as I<cv>. + +The C-level function pointer is supplied in I<ckfun>, and an SV argument +for it is supplied in I<ckobj>. 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<entersubop> is a pointer to the C<entersub> op, +which may be replaced by the check function, and I<namegv> supplies +the name that should be used by the check function to refer +to the callee of the C<entersub> 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<namegv> 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</cv_name>. You can force perl to pass a GV by including +C<CALL_CHECKER_REQUIRE_GV> in the I<flags>. + +The current setting for a particular CV can be retrieved by +L</cv_get_call_checker>. + +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L</cv_set_call_checker_flags>, which passes it the +C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. + +=cut +*/ + +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); + } else { + 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; + } + callmg->mg_ptr = FPTR2DPTR(char *, ckfun); + callmg->mg_obj = ckobj; + if (ckobj != (SV*)cv) { + SvREFCNT_inc_simple_void_NN(ckobj); + callmg->mg_flags |= MGf_REFCOUNTED; + } + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; + } +} + +static void +S_entersub_alloc_targ(pTHX_ OP * const o) +{ + o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP); + o->op_private |= OPpENTERSUB_HASTARG; +} + +OP * +Perl_ck_subr(pTHX_ OP *o) +{ + OP *aop, *cvop; + CV *cv; + GV *namegv; + SV **const_class = NULL; + + PERL_ARGS_ASSERT_CK_SUBR; + + aop = cUNOPx(o)->op_first; + if (!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + aop = OpSIBLING(aop); + for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; + cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; + + o->op_private &= ~1; + o->op_private |= (PL_hints & HINT_STRICT_REFS); + if (PERLDB_SUB && PL_curstash != PL_debstash) + o->op_private |= OPpENTERSUB_DB; + switch (cvop->op_type) { + case OP_RV2CV: + o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + op_null(cvop); + break; + case OP_METHOD: + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: + case OP_METHOD_REDIR_SUPER: + if (aop->op_type == OP_CONST) { + aop->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(aop)->op_sv; + } + else if (aop->op_type == OP_LIST) { + OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); + if (sib && sib->op_type == OP_CONST) { + sib->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(sib)->op_sv; + } + } + /* make class name a shared cow string to speedup method calls */ + /* constant string might be replaced with object, f.e. bigint */ + if (const_class && SvPOK(*const_class)) { + STRLEN len; + const char* str = SvPV(*const_class, len); + if (len) { + SV* const shared = newSVpvn_share( + str, SvUTF8(*const_class) + ? -(SSize_t)len : (SSize_t)len, + 0 + ); + if (SvREADONLY(*const_class)) + SvREADONLY_on(shared); + SvREFCNT_dec(*const_class); + *const_class = shared; + } + } + break; + } + + if (!cv) { + S_entersub_alloc_targ(aTHX_ o); + return ck_entersub_args_list(o); + } else { + Perl_call_checker ckfun; + SV *ckobj; + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (CvISXSUB(cv) || !CvROOT(cv)) + S_entersub_alloc_targ(aTHX_ o); + 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 (!namegv) return ck_entersub_args_list(o); + + } + return ckfun(aTHX_ o, namegv, ckobj); + } +} + +OP * +Perl_ck_svconst(pTHX_ OP *o) +{ + SV * const sv = cSVOPo->op_sv; + PERL_ARGS_ASSERT_CK_SVCONST; + PERL_UNUSED_CONTEXT; +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(sv)) sv_force_normal(sv); +#elif defined(PERL_NEW_COPY_ON_WRITE) + /* Since the read-only flag may be used to protect a string buffer, we + cannot do copy-on-write with existing read-only scalars that are not + already copy-on-write scalars. To allow $_ = "hello" to do COW with + that constant, mark the constant as COWable here, if it is not + already read-only. */ + 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); + return o; +} + +OP * +Perl_ck_trunc(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_TRUNC; + + if (o->op_flags & OPf_KIDS) { + SVOP *kid = (SVOP*)cUNOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = (SVOP*)OpSIBLING(kid); + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE) && + !kid->op_folded) + { + o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; + } + } + return ck_fun(o); +} + +OP * +Perl_ck_substr(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_SUBSTR; + + o = ck_fun(o); + if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { + OP *kid = cLISTOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = OpSIBLING(kid); + if (kid) + kid->op_flags |= OPf_MOD; + + } + return o; +} + +OP * +Perl_ck_tell(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_TELL; + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + return o; +} + +OP * +Perl_ck_each(pTHX_ OP *o) +{ + dVAR; + OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; + const unsigned orig_type = o->op_type; + const unsigned array_type = orig_type == OP_EACH ? OP_AEACH + : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; + const unsigned ref_type = orig_type == OP_EACH ? OP_REACH + : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES; + + PERL_ARGS_ASSERT_CK_EACH; + + if (kid) { + switch (kid->op_type) { + case OP_PADHV: + case OP_RV2HV: + break; + case OP_PADAV: + case OP_RV2AV: + OpTYPE_set(o, array_type); + break; + case OP_CONST: + if (kid->op_private == OPpCONST_BARE + || !SvROK(cSVOPx_sv(kid)) + || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV + && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) + ) + /* we let ck_fun handle it */ + break; + default: + OpTYPE_set(o, ref_type); + scalar(kid); + } + } + /* if treating as a reference, defer additional checks to runtime */ + 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 * +Perl_ck_length(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_LENGTH; + + o = ck_fun(o); + + if (ckWARN(WARN_SYNTAX)) { + const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; + + if (kid) { + SV *name = NULL; + const bool hash = kid->op_type == OP_PADHV + || kid->op_type == OP_RV2HV; + switch (kid->op_type) { + case OP_PADHV: + case OP_PADAV: + case OP_RV2HV: + case OP_RV2AV: + name = S_op_varname(aTHX_ kid); + break; + default: + return o; + } + if (name) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %"SVf" (did you mean \"scalar(%s%"SVf + ")\"?)", + SVfARG(name), hash ? "keys " : "", SVfARG(name) + ); + else if (hash) + /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); + else + /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on @array (did you mean \"scalar(@array)\"?)"); + } + } + + return o; +} + +/* Check for in place reverse and sort assignments like "@a = reverse @a" + and modify the optree to make them work inplace */ + +STATIC void +S_inplace_aassign(pTHX_ OP *o) { + + OP *modop, *modop_pushmark; + OP *oright; + OP *oleft, *oleft_pushmark; + + PERL_ARGS_ASSERT_INPLACE_AASSIGN; + + assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID); + + assert(cUNOPo->op_first->op_type == OP_NULL); + modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; + assert(modop_pushmark->op_type == OP_PUSHMARK); + modop = OpSIBLING(modop_pushmark); + + if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) + return; + + /* no other operation except sort/reverse */ + if (OpHAS_SIBLING(modop)) + return; + + assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); + if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return; + + if (modop->op_flags & OPf_STACKED) { + /* skip sort subroutine/block */ + assert(oright->op_type == OP_NULL); + oright = OpSIBLING(oright); + } + + assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL); + oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first; + assert(oleft_pushmark->op_type == OP_PUSHMARK); + oleft = OpSIBLING(oleft_pushmark); + + /* Check the lhs is an array */ + if (!oleft || + (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) + || OpHAS_SIBLING(oleft) + || (oleft->op_private & OPpLVAL_INTRO) + ) + return; + + /* Only one thing on the rhs */ + if (OpHAS_SIBLING(oright)) + return; + + /* check the array is the same on both sides */ + if (oleft->op_type == OP_RV2AV) { + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cUNOPx(oleft )->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return; + } + else if (oright->op_type != OP_PADAV + || oright->op_targ != oleft->op_targ + ) + return; + + /* This actually is an inplace assignment */ + + modop->op_private |= OPpSORT_INPLACE; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + + /* remove the aassign op and the lhs */ + op_null(o); + op_null(oleft_pushmark); + if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) + op_null(cUNOPx(oleft)->op_first); + op_null(oleft); +} + + + +/* S_maybe_multideref(): given an op_next chain of ops beginning at 'start' + * that potentially represent a series of one or more aggregate derefs + * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert + * the whole chain to a single OP_MULTIDEREF op (maybe with a few + * additional ops left in too). + * + * The caller will have already verified that the first few ops in the + * chain following 'start' indicate a multideref candidate, and will have + * set 'orig_o' to the point further on in the chain where the first index + * expression (if any) begins. 'orig_action' specifies what type of + * beginning has already been determined by the ops between start..orig_o + * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc). + * + * 'hints' contains any hints flags that need adding (currently just + * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller. + */ + +void +S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) +{ + dVAR; + int pass; + UNOP_AUX_item *arg_buf = NULL; + bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */ + int index_skip = -1; /* don't output index arg on this action */ + + /* similar to regex compiling, do two passes; the first pass + * determines whether the op chain is convertible and calculates the + * buffer size; the second pass populates the buffer and makes any + * changes necessary to ops (such as moving consts to the pad on + * threaded builds). + * + * NB: for things like Coverity, note that both passes take the same + * path through the logic tree (except for 'if (pass)' bits), since + * both passes are following the same op_next chain; and in + * particular, if it would return early on the second pass, it would + * already have returned early on the first pass. + */ + for (pass = 0; pass < 2; pass++) { + OP *o = orig_o; + UV action = orig_action; + OP *first_elem_op = NULL; /* first seen aelem/helem */ + OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */ + int action_count = 0; /* number of actions seen so far */ + int action_ix = 0; /* action_count % (actions per IV) */ + bool next_is_hash = FALSE; /* is the next lookup to be a hash? */ + bool is_last = FALSE; /* no more derefs to follow */ + bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */ + UNOP_AUX_item *arg = arg_buf; + UNOP_AUX_item *action_ptr = arg_buf; + + if (pass) + action_ptr->uv = 0; + arg++; + + switch (action) { + case MDEREF_HV_gvsv_vivify_rv2hv_helem: + case MDEREF_HV_gvhv_helem: + next_is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_gvsv_vivify_rv2av_aelem: + case MDEREF_AV_gvav_aelem: + if (pass) { +#ifdef USE_ITHREADS + arg->pad_offset = cPADOPx(start)->op_padix; + /* stop it being swiped when nulled */ + cPADOPx(start)->op_padix = 0; +#else + arg->sv = cSVOPx(start)->op_sv; + cSVOPx(start)->op_sv = NULL; +#endif + } + arg++; + break; + + case MDEREF_HV_padhv_helem: + case MDEREF_HV_padsv_vivify_rv2hv_helem: + next_is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_padav_aelem: + case MDEREF_AV_padsv_vivify_rv2av_aelem: + if (pass) { + arg->pad_offset = start->op_targ; + /* we skip setting op_targ = 0 for now, since the intact + * OP_PADXV is needed by S_check_hash_fields_and_hekify */ + reset_start_targ = TRUE; + } + arg++; + break; + + case MDEREF_HV_pop_rv2hv_helem: + next_is_hash = TRUE; + /* FALLTHROUGH */ + case MDEREF_AV_pop_rv2av_aelem: + break; + + default: + NOT_REACHED; /* NOTREACHED */ + return; + } + + while (!is_last) { + /* look for another (rv2av/hv; get index; + * aelem/helem/exists/delele) sequence */ + + OP *kid; + bool is_deref; + bool ok; + UV index_type = MDEREF_INDEX_none; + + if (action_count) { + /* if this is not the first lookup, consume the rv2av/hv */ + + /* for N levels of aggregate lookup, we normally expect + * that the first N-1 [ah]elem ops will be flagged as + * /DEREF (so they autovivifiy if necessary), and the last + * lookup op not to be. + * For other things (like @{$h{k1}{k2}}) extra scope or + * leave ops can appear, so abandon the effort in that + * case */ + if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV) + return; + + /* rv2av or rv2hv sKR/1 */ + + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + |OPf_REF|OPf_MOD|OPf_SPECIAL))); + if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) + return; + + /* at this point, we wouldn't expect any of these + * possible private flags: + * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO + * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only) + */ + ASSUME(!(o->op_private & + ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING))); + + hints = (o->op_private & OPpHINT_STRICT_REFS); + + /* make sure the type of the previous /DEREF matches the + * type of the next lookup */ + ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV)); + top_op = o; + + action = next_is_hash + ? MDEREF_HV_vivify_rv2hv_helem + : MDEREF_AV_vivify_rv2av_aelem; + o = o->op_next; + } + + /* if this is the second pass, and we're at the depth where + * previously we encountered a non-simple index expression, + * stop processing the index at this point */ + if (action_count != index_skip) { + + /* look for one or more simple ops that return an array + * index or hash key */ + + switch (o->op_type) { + case OP_PADSV: + /* it may be a lexical var index */ + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS + |OPf_REF|OPf_MOD|OPf_SPECIAL))); + ASSUME(!(o->op_private & + ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); + + if ( OP_GIMME(o,0) == G_SCALAR + && !(o->op_flags & (OPf_REF|OPf_MOD)) + && o->op_private == 0) + { + if (pass) + arg->pad_offset = o->op_targ; + arg++; + index_type = MDEREF_INDEX_padsv; + o = o->op_next; + } + break; + + case OP_CONST: + if (next_is_hash) { + /* it's a constant hash index */ + if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK))) + /* "use constant foo => FOO; $h{+foo}" for + * some weird FOO, can leave you with constants + * that aren't simple strings. It's not worth + * the extra hassle for those edge cases */ + break; + + if (pass) { + UNOP *rop = NULL; + OP * helem_op = o->op_next; + + ASSUME( helem_op->op_type == OP_HELEM + || helem_op->op_type == OP_NULL); + if (helem_op->op_type == OP_HELEM) { + rop = (UNOP*)(((BINOP*)helem_op)->op_first); + if ( helem_op->op_private & OPpLVAL_INTRO + || rop->op_type != OP_RV2HV + ) + rop = NULL; + } + S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo); + +#ifdef USE_ITHREADS + /* Relocate sv to the pad for thread safety */ + op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); + arg->pad_offset = o->op_targ; + o->op_targ = 0; +#else + arg->sv = cSVOPx_sv(o); +#endif + } + } + else { + /* it's a constant array index */ + IV iv; + SV *ix_sv = cSVOPo->op_sv; + if (!SvIOK(ix_sv)) + break; + iv = SvIV(ix_sv); + + if ( action_count == 0 + && iv >= -128 + && iv <= 127 + && ( action == MDEREF_AV_padav_aelem + || action == MDEREF_AV_gvav_aelem) + ) + maybe_aelemfast = TRUE; + + if (pass) { + arg->iv = iv; + SvREFCNT_dec_NN(cSVOPo->op_sv); + } + } + if (pass) + /* we've taken ownership of the SV */ + cSVOPo->op_sv = NULL; + arg++; + index_type = MDEREF_INDEX_const; + o = o->op_next; + break; + + case OP_GV: + /* it may be a package var index */ + + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL))); + ASSUME(!(o->op_private & ~(OPpEARLY_CV))); + if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR + || o->op_private != 0 + ) + break; + + kid = o->op_next; + if (kid->op_type != OP_RV2SV) + break; + + ASSUME(!(kid->op_flags & + ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF + |OPf_SPECIAL|OPf_PARENS))); + ASSUME(!(kid->op_private & + ~(OPpARG1_MASK + |OPpHINT_STRICT_REFS|OPpOUR_INTRO + |OPpDEREF|OPpLVAL_INTRO))); + if( (kid->op_flags &~ OPf_PARENS) + != (OPf_WANT_SCALAR|OPf_KIDS) + || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS)) + ) + break; + + if (pass) { +#ifdef USE_ITHREADS + arg->pad_offset = cPADOPx(o)->op_padix; + /* stop it being swiped when nulled */ + cPADOPx(o)->op_padix = 0; +#else + arg->sv = cSVOPx(o)->op_sv; + cSVOPo->op_sv = NULL; +#endif + } + arg++; + index_type = MDEREF_INDEX_gvsv; + o = kid->op_next; + break; + + } /* switch */ + } /* action_count != index_skip */ + + action |= index_type; + + + /* at this point we have either: + * * detected what looks like a simple index expression, + * and expect the next op to be an [ah]elem, or + * an nulled [ah]elem followed by a delete or exists; + * * found a more complex expression, so something other + * than the above follows. + */ + + /* possibly an optimised away [ah]elem (where op_next is + * exists or delete) */ + if (o->op_type == OP_NULL) + o = o->op_next; + + /* at this point we're looking for an OP_AELEM, OP_HELEM, + * OP_EXISTS or OP_DELETE */ + + /* if something like arybase (a.k.a $[ ) is in scope, + * abandon optimisation attempt */ + if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM) + && PL_check[o->op_type] != Perl_ck_null) + return; + + if ( o->op_type != OP_AELEM + || (o->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) + ) + maybe_aelemfast = FALSE; + + /* look for aelem/helem/exists/delete. If it's not the last elem + * lookup, it *must* have OPpDEREF_AV/HV, but not many other + * flags; if it's the last, then it mustn't have + * OPpDEREF_AV/HV, but may have lots of other flags, like + * OPpLVAL_INTRO etc + */ + + if ( index_type == MDEREF_INDEX_none + || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM + && o->op_type != OP_EXISTS && o->op_type != OP_DELETE) + ) + ok = FALSE; + else { + /* we have aelem/helem/exists/delete with valid simple index */ + + is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM) + && ( (o->op_private & OPpDEREF) == OPpDEREF_AV + || (o->op_private & OPpDEREF) == OPpDEREF_HV); + + if (is_deref) { + ASSUME(!(o->op_flags & + ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS))); + ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF))); + + ok = (o->op_flags &~ OPf_PARENS) + == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD) + && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK)); + } + else if (o->op_type == OP_EXISTS) { + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + |OPf_REF|OPf_MOD|OPf_SPECIAL))); + ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB))); + ok = !(o->op_private & ~OPpARG1_MASK); + } + else if (o->op_type == OP_DELETE) { + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + |OPf_REF|OPf_MOD|OPf_SPECIAL))); + ASSUME(!(o->op_private & + ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO))); + /* don't handle slices or 'local delete'; the latter + * is fairly rare, and has a complex runtime */ + ok = !(o->op_private & ~OPpARG1_MASK); + if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM)) + /* skip handling run-tome error */ + ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL)); + } + else { + ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM); + ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD + |OPf_PARENS|OPf_REF|OPf_SPECIAL))); + ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB + |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO))); + ok = (o->op_private & OPpDEREF) != OPpDEREF_SV; + } + } + + if (ok) { + if (!first_elem_op) + first_elem_op = o; + top_op = o; + if (is_deref) { + next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV); + o = o->op_next; + } + else { + is_last = TRUE; + action |= MDEREF_FLAG_last; + } + } + else { + /* at this point we have something that started + * promisingly enough (with rv2av or whatever), but failed + * to find a simple index followed by an + * aelem/helem/exists/delete. If this is the first action, + * give up; but if we've already seen at least one + * aelem/helem, then keep them and add a new action with + * MDEREF_INDEX_none, which causes it to do the vivify + * from the end of the previous lookup, and do the deref, + * but stop at that point. So $a[0][expr] will do one + * av_fetch, vivify and deref, then continue executing at + * expr */ + if (!action_count) + return; + is_last = TRUE; + index_skip = action_count; + action |= MDEREF_FLAG_last; + } + + if (pass) + action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT)); + action_ix++; + action_count++; + /* if there's no space for the next action, create a new slot + * for it *before* we start adding args for that action */ + if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) { + action_ptr = arg; + if (pass) + arg->uv = 0; + arg++; + action_ix = 0; + } + } /* while !is_last */ + + /* success! */ + + if (pass) { + OP *mderef; + OP *p, *q; + + mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf); + if (index_skip == -1) { + mderef->op_flags = o->op_flags + & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0)); + if (o->op_type == OP_EXISTS) + mderef->op_private = OPpMULTIDEREF_EXISTS; + else if (o->op_type == OP_DELETE) + mderef->op_private = OPpMULTIDEREF_DELETE; + else + mderef->op_private = o->op_private + & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO); + } + /* accumulate strictness from every level (although I don't think + * they can actually vary) */ + mderef->op_private |= hints; + + /* integrate the new multideref op into the optree and the + * op_next chain. + * + * In general an op like aelem or helem has two child + * sub-trees: the aggregate expression (a_expr) and the + * index expression (i_expr): + * + * aelem + * | + * a_expr - i_expr + * + * The a_expr returns an AV or HV, while the i-expr returns an + * index. In general a multideref replaces most or all of a + * multi-level tree, e.g. + * + * exists + * | + * ex-aelem + * | + * rv2av - i_expr1 + * | + * helem + * | + * rv2hv - i_expr2 + * | + * aelem + * | + * a_expr - i_expr3 + * + * With multideref, all the i_exprs will be simple vars or + * constants, except that i_expr1 may be arbitrary in the case + * of MDEREF_INDEX_none. + * + * The bottom-most a_expr will be either: + * 1) a simple var (so padXv or gv+rv2Xv); + * 2) a simple scalar var dereferenced (e.g. $r->[0]): + * so a simple var with an extra rv2Xv; + * 3) or an arbitrary expression. + * + * 'start', the first op in the execution chain, will point to + * 1),2): the padXv or gv op; + * 3): the rv2Xv which forms the last op in the a_expr + * execution chain, and the top-most op in the a_expr + * subtree. + * + * For all cases, the 'start' node is no longer required, + * but we can't free it since one or more external nodes + * may point to it. E.g. consider + * $h{foo} = $a ? $b : $c + * Here, both the op_next and op_other branches of the + * cond_expr point to the gv[*h] of the hash expression, so + * we can't free the 'start' op. + * + * For expr->[...], we need to save the subtree containing the + * expression; for the other cases, we just need to save the + * start node. + * So in all cases, we null the start op and keep it around by + * making it the child of the multideref op; for the expr-> + * case, the expr will be a subtree of the start node. + * + * So in the simple 1,2 case the optree above changes to + * + * ex-exists + * | + * multideref + * | + * ex-gv (or ex-padxv) + * + * with the op_next chain being + * + * -> ex-gv -> multideref -> op-following-ex-exists -> + * + * In the 3 case, we have + * + * ex-exists + * | + * multideref + * | + * ex-rv2xv + * | + * rest-of-a_expr + * subtree + * + * and + * + * -> rest-of-a_expr subtree -> + * ex-rv2xv -> multideref -> op-following-ex-exists -> + * + * + * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none, + * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the + * multideref attached as the child, e.g. + * + * exists + * | + * ex-aelem + * | + * ex-rv2av - i_expr1 + * | + * multideref + * | + * ex-whatever + * + */ + + /* if we free this op, don't free the pad entry */ + if (reset_start_targ) + start->op_targ = 0; + + + /* Cut the bit we need to save out of the tree and attach to + * the multideref op, then free the rest of the tree */ + + /* find parent of node to be detached (for use by splice) */ + p = first_elem_op; + if ( orig_action == MDEREF_AV_pop_rv2av_aelem + || orig_action == MDEREF_HV_pop_rv2hv_helem) + { + /* there is an arbitrary expression preceding us, e.g. + * expr->[..]? so we need to save the 'expr' subtree */ + if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE) + p = cUNOPx(p)->op_first; + ASSUME( start->op_type == OP_RV2AV + || start->op_type == OP_RV2HV); + } + else { + /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem + * above for exists/delete. */ + while ( (p->op_flags & OPf_KIDS) + && cUNOPx(p)->op_first != start + ) + p = cUNOPx(p)->op_first; + } + ASSUME(cUNOPx(p)->op_first == start); + + /* detach from main tree, and re-attach under the multideref */ + op_sibling_splice(mderef, NULL, 0, + op_sibling_splice(p, NULL, 1, NULL)); + op_null(start); + + start->op_next = mderef; + + mderef->op_next = index_skip == -1 ? o->op_next : o; + + /* excise and free the original tree, and replace with + * the multideref op */ + p = op_sibling_splice(top_op, NULL, -1, mderef); + while (p) { + q = OpSIBLING(p); + op_free(p); + p = q; + } + op_null(top_op); + } + else { + Size_t size = arg - arg_buf; + + if (maybe_aelemfast && action_count == 1) + return; + + arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc( + sizeof(UNOP_AUX_item) * (size + 1)); + /* for dumping etc: store the length in a hidden first slot; + * we set the op_aux pointer to the second slot */ + arg_buf->uv = size; + arg_buf++; + } + } /* for (pass = ...) */ +} + + + +/* mechanism for deferring recursion in rpeep() */ + +#define MAX_DEFERRED 4 + +#define DEFER(o) \ + STMT_START { \ + if (defer_ix == (MAX_DEFERRED-1)) { \ + 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); \ + } STMT_END + +#define IS_AND_OP(o) (o->op_type == OP_AND) +#define IS_OR_OP(o) (o->op_type == OP_OR) + + +/* 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 */ + +void +Perl_rpeep(pTHX_ OP *o) +{ + dVAR; + OP* oldop = NULL; + OP* oldoldop = NULL; + 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; + ENTER; + SAVEOP(); + SAVEVPTR(PL_curcop); + for (;; o = o->op_next) { + if (o && o->op_opt) + o = NULL; + if (!o) { + while (defer_ix >= 0) { + OP **defer = + defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; + CALL_RPEEP(*defer); + S_prune_chain_head(defer); + } + break; + } + + redo: + /* By default, this op has now been optimised. A couple of cases below + clear this again. */ + o->op_opt = 1; + PL_op = o; + + /* look for a series of 1 or more aggregate derefs, e.g. + * $a[1]{foo}[$i]{$k} + * and replace with a single OP_MULTIDEREF op. + * Each index must be either a const, or a simple variable, + * + * First, look for likely combinations of starting ops, + * corresponding to (global and lexical variants of) + * $a[...] $h{...} + * $r->[...] $r->{...} + * (preceding expression)->[...] + * (preceding expression)->{...} + * and if so, call maybe_multideref() to do a full inspection + * of the op chain and if appropriate, replace with an + * OP_MULTIDEREF + */ + { + UV action; + OP *o2 = o; + U8 hints = 0; + + switch (o2->op_type) { + case OP_GV: + /* $pkg[..] : gv[*pkg] + * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */ + + /* Fail if there are new op flag combinations that we're + * not aware of, rather than: + * * silently failing to optimise, or + * * silently optimising the flag away. + * If this ASSUME starts failing, examine what new flag + * has been added to the op, and decide whether the + * optimisation should still occur with that flag, then + * update the code accordingly. This applies to all the + * other ASSUMEs in the block of code too. + */ + ASSUME(!(o2->op_flags & + ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL))); + ASSUME(!(o2->op_private & ~OPpEARLY_CV)); + + o2 = o2->op_next; + + if (o2->op_type == OP_RV2AV) { + action = MDEREF_AV_gvav_aelem; + goto do_deref; + } + + if (o2->op_type == OP_RV2HV) { + action = MDEREF_HV_gvhv_helem; + goto do_deref; + } + + if (o2->op_type != OP_RV2SV) + break; + + /* at this point we've seen gv,rv2sv, so the only valid + * construct left is $pkg->[] or $pkg->{} */ + + ASSUME(!(o2->op_flags & OPf_STACKED)); + if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) + != (OPf_WANT_SCALAR|OPf_MOD)) + break; + + ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS + |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO))); + if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO)) + break; + if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV + && (o2->op_private & OPpDEREF) != OPpDEREF_HV) + break; + + o2 = o2->op_next; + if (o2->op_type == OP_RV2AV) { + action = MDEREF_AV_gvsv_vivify_rv2av_aelem; + goto do_deref; + } + if (o2->op_type == OP_RV2HV) { + action = MDEREF_HV_gvsv_vivify_rv2hv_helem; + goto do_deref; + } + break; + + case OP_PADSV: + /* $lex->[...]: padsv[$lex] sM/DREFAV */ + + ASSUME(!(o2->op_flags & + ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL))); + if ((o2->op_flags & + (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) + != (OPf_WANT_SCALAR|OPf_MOD)) + break; + + ASSUME(!(o2->op_private & + ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO))); + /* skip if state or intro, or not a deref */ + if ( o2->op_private != OPpDEREF_AV + && o2->op_private != OPpDEREF_HV) + break; + + o2 = o2->op_next; + if (o2->op_type == OP_RV2AV) { + action = MDEREF_AV_padsv_vivify_rv2av_aelem; + goto do_deref; + } + if (o2->op_type == OP_RV2HV) { + action = MDEREF_HV_padsv_vivify_rv2hv_helem; + goto do_deref; + } + break; + + case OP_PADAV: + case OP_PADHV: + /* $lex[..]: padav[@lex:1,2] sR * + * or $lex{..}: padhv[%lex:1,2] sR */ + ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS| + OPf_REF|OPf_SPECIAL))); + if ((o2->op_flags & + (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL)) + != (OPf_WANT_SCALAR|OPf_REF)) + break; + if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF)) + break; + /* OPf_PARENS isn't currently used in this case; + * if that changes, let us know! */ + ASSUME(!(o2->op_flags & OPf_PARENS)); + + /* at this point, we wouldn't expect any of the remaining + * possible private flags: + * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL, + * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB + * + * OPpSLICEWARNING shouldn't affect runtime + */ + ASSUME(!(o2->op_private & ~(OPpSLICEWARNING))); + + action = o2->op_type == OP_PADAV + ? MDEREF_AV_padav_aelem + : MDEREF_HV_padhv_helem; + o2 = o2->op_next; + S_maybe_multideref(aTHX_ o, o2, action, 0); + break; + + + case OP_RV2AV: + case OP_RV2HV: + action = o2->op_type == OP_RV2AV + ? MDEREF_AV_pop_rv2av_aelem + : MDEREF_HV_pop_rv2hv_helem; + /* FALLTHROUGH */ + do_deref: + /* (expr)->[...]: rv2av sKR/1; + * (expr)->{...}: rv2hv sKR/1; */ + + ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV); + + ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS + |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL))); + if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF)) + break; + + /* at this point, we wouldn't expect any of these + * possible private flags: + * OPpMAYBE_LVSUB, OPpLVAL_INTRO + * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only) + */ + ASSUME(!(o2->op_private & + ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING + |OPpOUR_INTRO))); + hints |= (o2->op_private & OPpHINT_STRICT_REFS); + + o2 = o2->op_next; + + S_maybe_multideref(aTHX_ o, o2, action, hints); + break; + + default: + break; + } + } + + + switch (o->op_type) { + case OP_DBSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + break; + 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 = OpSIBLING(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) + ||OP_TYPE_IS(sibling->op_next->op_next, + OP_LEAVESUBLV)) + && cUNOPx(sibling)->op_first == next + && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = OpSIBLING(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 = OpSIBLING(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(OpSIBLING(o) == pad1); + assert(OpSIBLING(pad1) == ns2); + assert(OpSIBLING(ns2) == pad2); + assert(OpSIBLING(pad2) == ns3); + + /* excise and delete ns2 */ + op_sibling_splice(NULL, pad1, 1, NULL); + op_free(ns2); + + /* excise pad1 and pad2 */ + op_sibling_splice(NULL, o, 2, NULL); + + /* create new listop, with children consisting of: + * a new pushmark, pad1, pad2. */ + newop = newLISTOP(OP_LIST, 0, pad1, pad2); + newop->op_flags |= OPf_PARENS; + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + /* insert newop between o and ns3 */ + op_sibling_splice(NULL, o, 0, newop); + + /*fixup op_next chain */ + newpm = cUNOPx(newop)->op_first; /* pushmark */ + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + /* Ensure pushmark has this flag if padops do */ + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { + newpm->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. */ + if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { + OP *nextop = o->op_next; + while (nextop && nextop->op_type == OP_NULL) + nextop = nextop->op_next; + + if (nextop && (nextop->op_type == OP_NEXTSTATE)) { + op_null(o); + if (oldop) + oldop->op_next = nextop; + /* Skip (old)oldop assignment since the current oldop's + op_next already points to the next op. */ + continue; + } + } + break; + + case OP_CONCAT: + if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { + if (o->op_next->op_private & OPpTARGET_MY) { + if (o->op_flags & OPf_STACKED) /* chained concats */ + break; /* ignore_optimization */ + else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ + o->op_targ = o->op_next->op_targ; + o->op_next->op_targ = 0; + o->op_private |= OPpTARGET_MY; + } + } + op_null(o->op_next); + } + break; + case OP_STUB: + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { + break; /* Scalar stub must produce undef. List stub is noop */ + } + goto nothin; + case OP_NULL: + if (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE) + { + PL_curcop = ((COP*)o); + } + /* XXX: We avoid setting op_seq here to prevent later calls + to rpeep() from mistakenly concluding that optimisation + has already occurred. This doesn't fix the real problem, + though (See 20010220.007). AMS 20010719 */ + /* op_seq functionality is now replaced by op_opt */ + o->op_opt = 0; + /* FALLTHROUGH */ + case OP_SCALAR: + case OP_LINESEQ: + case OP_SCOPE: + nothin: + if (oldop) { + oldop->op_next = o->op_next; + o->op_opt = 0; + continue; + } + break; + + case OP_PUSHMARK: + + /* Given + 5 repeat/DOLIST + 3 ex-list + 1 pushmark + 2 scalar or const + 4 const[0] + convert repeat into a stub with no kids. + */ + if (o->op_next->op_type == OP_CONST + || ( o->op_next->op_type == OP_PADSV + && !(o->op_next->op_private & OPpLVAL_INTRO)) + || ( o->op_next->op_type == OP_GV + && o->op_next->op_next->op_type == OP_RV2SV + && !(o->op_next->op_next->op_private + & (OPpLVAL_INTRO|OPpOUR_INTRO)))) + { + const OP *kid = o->op_next->op_next; + if (o->op_next->op_type == OP_GV) + kid = kid->op_next; + /* kid is now the ex-list. */ + if (kid->op_type == OP_NULL + && (kid = kid->op_next)->op_type == OP_CONST + /* kid is now the repeat count. */ + && kid->op_next->op_type == OP_REPEAT + && kid->op_next->op_private & OPpREPEAT_DOLIST + && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST + && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0) + { + o = kid->op_next; /* repeat */ + assert(oldop); + oldop->op_next = o; + op_free(cBINOPo->op_first); + op_free(cBINOPo->op_last ); + o->op_flags &=~ OPf_KIDS; + /* stub is a baseop; repeat is a binop */ + STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP)); + OpTYPE_set(o, OP_STUB); + o->op_private = 0; + break; + } + } + + /* Convert a series of PAD ops for my vars plus support into a + * single padrange op. Basically + * + * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest + * + * becomes, depending on circumstances, one of + * + * padrange ----------------------------------> (list) -> rest + * padrange --------------------------------------------> rest + * + * where all the pad indexes are sequential and of the same type + * (INTRO or not). + * We convert the pushmark into a padrange op, then skip + * any other pad ops, and possibly some trailing ops. + * Note that we don't null() the skipped ops, to make it + * easier for Deparse to undo this optimisation (and none of + * the skipped ops are holding any resourses). It also makes + * it easier for find_uninit_var(), as it can just ignore + * padrange, and examine the original pad ops. + */ + { + OP *p; + OP *followop = NULL; /* the op that will follow the padrange op */ + U8 count = 0; + U8 intro = 0; + PADOFFSET base = 0; /* init only to stop compiler whining */ + bool gvoid = 0; /* init only to stop compiler whining */ + bool defav = 0; /* seen (...) = @_ */ + bool reuse = 0; /* reuse an existing padrange op */ + + /* look for a pushmark -> gv[_] -> rv2av */ + + { + OP *rv2av, *q; + p = o->op_next; + if ( p->op_type == OP_GV + && cGVOPx_gv(p) == PL_defgv + && (rv2av = p->op_next) + && rv2av->op_type == OP_RV2AV + && !(rv2av->op_flags & OPf_REF) + && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) + && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) + ) { + q = rv2av->op_next; + if (q->op_type == OP_NULL) + q = q->op_next; + if (q->op_type == OP_PUSHMARK) { + defav = 1; + p = q; + } + } + } + if (!defav) { + p = o; + } + + /* scan for PAD ops */ + + for (p = p->op_next; p; p = p->op_next) { + if (p->op_type == OP_NULL) + continue; + + if (( p->op_type != OP_PADSV + && p->op_type != OP_PADAV + && p->op_type != OP_PADHV + ) + /* any private flag other than INTRO? e.g. STATE */ + || (p->op_private & ~OPpLVAL_INTRO) + ) + break; + + /* let $a[N] potentially be optimised into AELEMFAST_LEX + * instead */ + if ( p->op_type == OP_PADAV + && p->op_next + && p->op_next->op_type == OP_CONST + && p->op_next->op_next + && p->op_next->op_next->op_type == OP_AELEM + ) + break; + + /* for 1st padop, note what type it is and the range + * start; for the others, check that it's the same type + * and that the targs are contiguous */ + if (count == 0) { + intro = (p->op_private & OPpLVAL_INTRO); + base = p->op_targ; + gvoid = OP_GIMME(p,0) == G_VOID; + } + else { + if ((p->op_private & OPpLVAL_INTRO) != intro) + break; + /* Note that you'd normally expect targs to be + * contiguous in my($a,$b,$c), but that's not the case + * when external modules start doing things, e.g. + i* Function::Parameters */ + if (p->op_targ != base + count) + break; + assert(p->op_targ == base + count); + /* Either all the padops or none of the padops should + be in void context. Since we only do the optimisa- + tion for av/hv when the aggregate itself is pushed + on to the stack (one item), there is no need to dis- + tinguish list from scalar context. */ + if (gvoid != (OP_GIMME(p,0) == G_VOID)) + break; + } + + /* for AV, HV, only when we're not flattening */ + if ( p->op_type != OP_PADSV + && !gvoid + && !(p->op_flags & OPf_REF) + ) + break; + + if (count >= OPpPADRANGE_COUNTMASK) + break; + + /* there's a biggest base we can fit into a + * SAVEt_CLEARPADRANGE in pp_padrange */ + if (intro && base > + (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) + break; + + /* Success! We've got another valid pad op to optimise away */ + count++; + followop = p->op_next; + } + + if (count < 1 || (count == 1 && !defav)) + break; + + /* pp_padrange in specifically compile-time void context + * skips pushing a mark and lexicals; in all other contexts + * (including unknown till runtime) it pushes a mark and the + * lexicals. We must be very careful then, that the ops we + * optimise away would have exactly the same effect as the + * padrange. + * In particular in void context, we can only optimise to + * a padrange if see see the complete sequence + * pushmark, pad*v, ...., list + * which has the net effect of of leaving the markstack as it + * was. Not pushing on to the stack (whereas padsv does touch + * the stack) makes no difference in void context. + */ + assert(followop); + if (gvoid) { + if (followop->op_type == OP_LIST + && OP_GIMME(followop,0) == G_VOID + ) + { + followop = followop->op_next; /* skip OP_LIST */ + + /* consolidate two successive my(...);'s */ + + if ( oldoldop + && oldoldop->op_type == OP_PADRANGE + && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID + && (oldoldop->op_private & OPpLVAL_INTRO) == intro + && !(oldoldop->op_flags & OPf_SPECIAL) + ) { + U8 old_count; + assert(oldoldop->op_next == oldop); + assert( oldop->op_type == OP_NEXTSTATE + || oldop->op_type == OP_DBSTATE); + assert(oldop->op_next == o); + + old_count + = (oldoldop->op_private & OPpPADRANGE_COUNTMASK); + + /* 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; + } + } + + /* if there's any immediately following singleton + * my var's; then swallow them and the associated + * nextstates; i.e. + * my ($a,$b); my $c; my $d; + * is treated as + * my ($a,$b,$c,$d); + */ + + while ( ((p = followop->op_next)) + && ( p->op_type == OP_PADSV + || p->op_type == OP_PADAV + || 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 + ) { + count++; + followop = p->op_next; + } + } + else + break; + } + + if (reuse) { + assert(oldoldop->op_type == OP_PADRANGE); + oldoldop->op_next = followop; + oldoldop->op_private = (intro | count); + o = oldoldop; + oldop = NULL; + oldoldop = NULL; + } + else { + /* Convert the pushmark into a padrange. + * To make Deparse easier, we guarantee that a padrange was + * *always* formerly a pushmark */ + assert(o->op_type == OP_PUSHMARK); + o->op_next = followop; + OpTYPE_set(o, OP_PADRANGE); + o->op_targ = base; + /* bit 7: INTRO; bit 6..0: count */ + o->op_private = (intro | count); + o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL)) + | gvoid * OPf_WANT_VOID + | (defav ? OPf_SPECIAL : 0)); + } + break; + } + + case OP_PADAV: + case OP_PADSV: + case OP_PADHV: + /* Skip over state($x) in void context. */ + if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) + && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) + { + oldop->op_next = o->op_next; + goto redo_nextstate; + } + if (o->op_type != OP_PADAV) + break; + /* FALLTHROUGH */ + case OP_GV: + if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { + OP* const pop = (o->op_type == OP_PADAV) ? + o->op_next : o->op_next->op_next; + IV i; + if (pop && pop->op_type == OP_CONST && + ((PL_op = pop->op_next)) && + 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)) >= -128 && i <= 127) + { + GV *gv; + if (cSVOPx(pop)->op_private & OPpCONST_STRICT) + no_bareword_allowed(pop); + if (o->op_type == OP_GV) + op_null(o->op_next); + op_null(pop->op_next); + op_null(pop); + o->op_flags |= pop->op_next->op_flags & OPf_MOD; + o->op_next = pop->op_next->op_next; + o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; + o->op_private = (U8)i; + if (o->op_type == OP_GV) { + gv = cGVOPo_gv; + GvAVn(gv); + o->op_type = OP_AELEMFAST; + } + else + o->op_type = OP_AELEMFAST_LEX; + } + if (o->op_type != OP_GV) + break; + } + + /* Remove $foo from the op_next chain in void context. */ + if (oldop + && ( o->op_next->op_type == OP_RV2SV + || o->op_next->op_type == OP_RV2AV + || o->op_next->op_type == OP_RV2HV ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + && !(o->op_next->op_private & OPpLVAL_INTRO)) + { + oldop->op_next = o->op_next->op_next; + /* Reprocess the previous op if it is a nextstate, to + allow double-nextstate optimisation. */ + redo_nextstate: + if (oldop->op_type == OP_NEXTSTATE) { + oldop->op_opt = 0; + o = oldop; + oldop = oldoldop; + oldoldop = NULL; + goto redo; + } + o = oldop; + } + else if (o->op_next->op_type == OP_RV2SV) { + if (!(o->op_next->op_private & OPpDEREF)) { + op_null(o->op_next); + o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO + | OPpOUR_INTRO); + o->op_next = o->op_next->op_next; + OpTYPE_set(o, OP_GVSV); + } + } + else if (o->op_next->op_type == OP_READLINE + && o->op_next->op_next->op_type == OP_CONCAT + && (o->op_next->op_next->op_flags & OPf_STACKED)) + { + /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */ + OpTYPE_set(o, OP_RCATLINE); + o->op_flags |= OPf_STACKED; + op_null(o->op_next->op_next); + op_null(o->op_next); + } + + break; + +#define HV_OR_SCALARHV(op) \ + ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ + ? (op) \ + : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ + && ( cUNOPx(op)->op_first->op_type == OP_PADHV \ + || cUNOPx(op)->op_first->op_type == OP_RV2HV) \ + ? cUNOPx(op)->op_first \ + : NULL) + + case OP_NOT: + if ((fop = HV_OR_SCALARHV(cUNOP->op_first))) + fop->op_private |= OPpTRUEBOOL; + break; + + case OP_AND: + case OP_OR: + case OP_DOR: + fop = cLOGOP->op_first; + sop = OpSIBLING(fop); + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + while (o->op_next && ( o->op_type == o->op_next->op_type + || 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; + fop = HV_OR_SCALARHV(fop); + if (sop) sop = HV_OR_SCALARHV(sop); + if (fop || sop + ){ + OP * nop = o; + OP * lop = o; + if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { + while (nop && nop->op_next) { + switch (nop->op_next->op_type) { + case OP_NOT: + case OP_AND: + case OP_OR: + case OP_DOR: + lop = nop = nop->op_next; + break; + case OP_NULL: + nop = nop->op_next; + break; + default: + nop = NULL; + break; + } + } + } + if (fop) { + if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID + || o->op_type == OP_AND ) + fop->op_private |= OPpTRUEBOOL; + else if (!(lop->op_flags & OPf_WANT)) + fop->op_private |= OPpMAYBE_TRUEBOOL; + } + if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID + && sop) + sop->op_private |= OPpTRUEBOOL; + } + + + break; + + case OP_COND_EXPR: + if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) + fop->op_private |= OPpTRUEBOOL; +#undef HV_OR_SCALARHV + /* GERONIMO! */ /* FALLTHROUGH */ + + case OP_MAPWHILE: + case OP_GREPWHILE: + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: + case OP_RANGE: + case OP_ONCE: + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + DEFER(cLOGOP->op_other); + break; + + case OP_ENTERLOOP: + case OP_ENTERITER: + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; + /* a while(1) loop doesn't have an op_next that escapes the + * loop, so we have to explicitly follow the op_lastop to + * process the rest of the code */ + 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 && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); + break; + + case OP_SORT: { + OP *oright; + + if (o->op_flags & OPf_SPECIAL) { + /* first arg is a code block */ + OP * const nullop = OpSIBLING(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_targ == OP_DBSTATE )) + || 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 */ + oright = cUNOPo->op_first; + if (!oright || oright->op_type != OP_PUSHMARK) + break; + + if (o->op_private & OPpSORT_INPLACE) + break; + + /* reverse sort ... can be optimised. */ + if (!OpHAS_SIBLING(cUNOPo)) { + /* Nothing follows us on the list. */ + OP * const reverse = o->op_next; + + if (reverse->op_type == OP_REVERSE && + (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { + OP * const pushmark = cUNOPx(reverse)->op_first; + if (pushmark && (pushmark->op_type == OP_PUSHMARK) + && (OpSIBLING(cUNOPx(pushmark)) == o)) { + /* reverse -> pushmark -> sort */ + o->op_private |= OPpSORT_REVERSE; + op_null(reverse); + pushmark->op_next = oright->op_next; + op_null(oright); + } + } + } + + break; + } + + case OP_REVERSE: { + OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; + OP *gvop = NULL; + LISTOP *enter, *exlist; + + if (o->op_private & OPpSORT_INPLACE) + break; + + enter = (LISTOP *) o->op_next; + if (!enter) + break; + if (enter->op_type == OP_NULL) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + /* for $a (...) will have OP_GV then OP_RV2GV here. + for (...) just has an OP_GV. */ + if (enter->op_type == OP_GV) { + gvop = (OP *) enter; + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + if (enter->op_type == OP_RV2GV) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + } + + if (enter->op_type != OP_ENTERITER) + break; + + iter = enter->op_next; + if (!iter || iter->op_type != OP_ITER) + break; + + expushmark = enter->op_first; + if (!expushmark || expushmark->op_type != OP_NULL + || expushmark->op_targ != OP_PUSHMARK) + break; + + exlist = (LISTOP *) OpSIBLING(expushmark); + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_last != o) { + /* Mmm. Was expecting to point back to this op. */ + break; + } + theirmark = exlist->op_first; + if (!theirmark || theirmark->op_type != OP_PUSHMARK) + break; + + if (OpSIBLING(theirmark) != o) { + /* There's something between the mark and the reverse, eg + for (1, reverse (...)) + so no go. */ + break; + } + + ourmark = ((LISTOP *)o)->op_first; + if (!ourmark || ourmark->op_type != OP_PUSHMARK) + break; + + ourlast = ((LISTOP *)o)->op_last; + if (!ourlast || ourlast->op_next != o) + break; + + rv2av = OpSIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) + && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { + /* We're just reversing a single array. */ + rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; + enter->op_flags |= OPf_STACKED; + } + + /* We don't have control over who points to theirmark, so sacrifice + ours. */ + theirmark->op_next = ourmark->op_next; + theirmark->op_flags = ourmark->op_flags; + ourlast->op_next = gvop ? gvop : (OP *) enter; + op_null(ourmark); + op_null(o); + enter->op_private |= OPpITER_REVERSED; + iter->op_private |= OPpITER_REVERSED; + + break; + } + + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } + break; + + case OP_RUNCV: + if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) + && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) + { + SV *sv; + if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; + else { + sv = newRV((SV *)PL_compcv); + sv_rvweaken(sv); + SvREADONLY_on(sv); + } + OpTYPE_set(o, OP_CONST); + o->op_flags |= OPf_SPECIAL; + cSVOPo->op_sv = sv; + } + break; + + case OP_SASSIGN: + if (OP_GIMME(o,0) == G_VOID + || ( o->op_next->op_type == OP_LINESEQ + && ( o->op_next->op_next->op_type == OP_LEAVESUB + || ( o->op_next->op_next->op_type == OP_RETURN + && !CvLVALUE(PL_compcv))))) + { + OP *right = cBINOP->op_first; + if (right) { + /* sassign + * RIGHT + * substr + * pushmark + * arg1 + * arg2 + * ... + * becomes + * + * ex-sassign + * substr + * pushmark + * RIGHT + * arg1 + * arg2 + * ... + */ + OP *left = OpSIBLING(right); + if (left->op_type == OP_SUBSTR + && (left->op_private & 7) < 4) { + op_null(o); + /* 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; + } + } + } + break; + + case OP_AASSIGN: + /* We do the common-vars check here, rather than in newASSIGNOP + (as formerly), so that all lexical vars that get aliased are + marked as such before we do the check. */ + /* There can’t be common vars if the lhs is a stub. */ + if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first) + == cLISTOPx(cBINOPo->op_last)->op_last + && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB) + { + o->op_private &=~ OPpASSIGN_COMMON; + break; + } + if (o->op_private & OPpASSIGN_COMMON) { + /* See the comment before S_aassign_common_vars concerning + PL_generation sorcery. */ + PL_generation++; + if (!aassign_common_vars(o)) + o->op_private &=~ OPpASSIGN_COMMON; + } + else if (S_aassign_common_vars_aliases_only(aTHX_ o)) + o->op_private |= OPpASSIGN_COMMON; + break; + + case OP_CUSTOM: { + Perl_cpeep_t cpeep = + XopENTRYCUSTOM(o, xop_peep); + if (cpeep) + cpeep(aTHX_ o, oldop); + break; + } + + } + /* 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; +} + +void +Perl_peep(pTHX_ OP *o) +{ + CALL_RPEEP(o); +} + +/* +=head1 Custom Operators + +=for apidoc Ao||custom_op_xop +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 +*/ + +XOPRETANY +Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) +{ + SV *keysv; + HE *he = NULL; + XOP *xop; + + static const XOP xop_null = { 0, 0, 0, 0, 0 }; + + 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, + * which isn't guaranteed, but this is what the old custom OP code + * did. In principle it should be safer to Copy the bytes of the + * pointer into a PV: since the new interface is hidden behind + * functions, this can be changed later if necessary. */ + /* Change custom_op_xop if this ever happens */ + keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr))); + + if (PL_custom_ops) + he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); + + /* assume noone will have just registered a desc */ + if (!he && PL_custom_op_names && + (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) + ) { + const char *pv; + STRLEN l; + + /* XXX does all this need to be shared mem? */ + Newxz(xop, 1, XOP); + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_name, savepvn(pv, l)); + if (PL_custom_op_descs && + (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) + ) { + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_desc, savepvn(pv, l)); + } + Perl_custom_op_register(aTHX_ o->op_ppaddr, 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; /* NOTREACHED */ + 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; /* NOTREACHED */ + 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<perlguts/"Custom Operators">. + +=cut +*/ + +void +Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) +{ + SV *keysv; + + PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER; + + /* see the comment in custom_op_xop */ + keysv = sv_2mortal(newSViv(PTR2IV(ppaddr))); + + if (!PL_custom_ops) + PL_custom_ops = newHV(); + + if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0)) + Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); +} + +/* + +=for apidoc core_prototype + +This function assigns the prototype of the named core function to C<sv>, or +to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or +NULL if the core function has no prototype. C<code> is a code as returned +by C<keyword()>. It must not be equal to 0. + +=cut +*/ + +SV * +Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, + int * const opnum) +{ + int i = 0, n = 0, seen_question = 0, defgv = 0; + I32 oa; +#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) + char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ + bool nullret = FALSE; + + PERL_ARGS_ASSERT_CORE_PROTOTYPE; + + assert (code); + + if (!sv) sv = sv_newmortal(); + +#define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv + + switch (code < 0 ? -code : code) { + case KEY_and : case KEY_chop: case KEY_chomp: + case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec : + case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto : + case KEY_grep : case KEY_gt : case KEY_last : case KEY_le : + case KEY_lt : case KEY_map : case KEY_ne : case KEY_next : + case KEY_or : case KEY_print : case KEY_printf: case KEY_qr : + case KEY_redo : case KEY_require: case KEY_return: case KEY_say : + case KEY_select: case KEY_sort : case KEY_split : case KEY_system: + case KEY_x : case KEY_xor : + if (!opnum) return NULL; nullret = TRUE; goto findopnum; + case KEY_glob: retsetpvs("_;", OP_GLOB); + case KEY_keys: retsetpvs("+", OP_KEYS); + case KEY_values: retsetpvs("+", OP_VALUES); + case KEY_each: retsetpvs("+", OP_EACH); + case KEY_push: retsetpvs("+@", OP_PUSH); + case KEY_unshift: retsetpvs("+@", OP_UNSHIFT); + case KEY_pop: retsetpvs(";+", OP_POP); + case KEY_shift: retsetpvs(";+", OP_SHIFT); + case KEY_pos: retsetpvs(";\\[$*]", OP_POS); + case KEY_splice: + retsetpvs("+;$$@", OP_SPLICE); + case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: + retsetpvs("", 0); + case KEY_evalbytes: + name = "entereval"; break; + case KEY_readpipe: + name = "backtick"; + } + +#undef retsetpvs + + findopnum: + while (i < MAXO) { /* The slow way. */ + if (strEQ(name, PL_op_name[i]) + || strEQ(name, PL_op_desc[i])) + { + if (nullret) { assert(opnum); *opnum = i; return NULL; } + goto found; + } + i++; + } + return NULL; + found: + defgv = PL_opargs[i] & OA_DEFGV; + oa = PL_opargs[i] >> OASHIFT; + while (oa) { + if (oa & OA_OPTIONAL && !seen_question && ( + !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF + )) { + seen_question = 1; + str[n++] = ';'; + } + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF + /* But globs are already references (kinda) */ + && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF + ) { + str[n++] = '\\'; + } + if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF + && !scalar_mod_type(NULL, i)) { + str[n++] = '['; + str[n++] = '$'; + str[n++] = '@'; + str[n++] = '%'; + if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; + str[n++] = '*'; + str[n++] = ']'; + } + else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; + if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { + str[n-1] = '_'; defgv = 0; + } + oa = oa >> 4; + } + if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';'; + str[n++] = '\0'; + sv_setpvn(sv, str, n - 1); + if (opnum) *opnum = i; + return sv; +} + +OP * +Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, + const int opnum) +{ + OP * const argop = newSVOP(OP_COREARGS,0,coreargssv); + OP *o; + + PERL_ARGS_ASSERT_CORESUB_OP; + + switch(opnum) { + case 0: + return op_append_elem(OP_LINESEQ, + argop, + newSLICEOP(0, + newSVOP(OP_CONST, 0, newSViv(-code % 3)), + newOP(OP_CALLER,0) + ) + ); + case OP_SELECT: /* which represents OP_SSELECT as well */ + if (code) + return newCONDOP( + 0, + newBINOP(OP_GT, 0, + newAVREF(newGVOP(OP_GV, 0, PL_defgv)), + newSVOP(OP_CONST, 0, newSVuv(1)) + ), + coresub_op(newSVuv((UV)OP_SSELECT), 0, + OP_SSELECT), + coresub_op(coreargssv, 0, OP_SELECT) + ); + /* FALLTHROUGH */ + default: + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_BASEOP: + return op_append_elem( + OP_LINESEQ, argop, + newOP(opnum, + opnum == OP_WANTARRAY || opnum == OP_RUNCV + ? OPpOFFBYONE << 8 : 0) + ); + case OA_BASEOP_OR_UNOP: + if (opnum == OP_ENTEREVAL) { + o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); + if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; + } + else o = newUNOP(opnum,0,argop); + if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; + else { + onearg: + if (is_handle_constructor(o, 1)) + argop->op_private |= OPpCOREARGS_DEREF1; + if (scalar_mod_type(NULL, opnum)) + argop->op_private |= OPpCOREARGS_SCALARMOD; + } + return o; + default: + o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); + if (is_handle_constructor(o, 2)) + argop->op_private |= OPpCOREARGS_DEREF2; + if (opnum == OP_SUBSTR) { + o->op_private |= OPpMAYBE_LVSUB; + return o; + } + else goto onearg; + } + } +} + +void +Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, + SV * const *new_const_svp) +{ + const char *hvname; + bool is_const = !!CvCONST(old_cv); + SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL; + + PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; + + if (is_const && new_const_svp && old_const_sv == *new_const_svp) + return; + /* They are 2 constant subroutines generated from + the same constant. This probably means that + they are really the "same" proxy subroutine + instantiated in 2 places. Most likely this is + when a constant is exported twice. Don't warn. + */ + if ( + (ckWARN(WARN_REDEFINE) + && !( + CvGV(old_cv) && GvSTASH(CvGV(old_cv)) + && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 + && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), + strEQ(hvname, "autouse")) + ) + ) + || (is_const + && ckWARN_d(WARN_REDEFINE) + && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) + ) + ) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + is_const + ? "Constant subroutine %"SVf" redefined" + : "Subroutine %"SVf" redefined", + SVfARG(name)); +} + +/* +=head1 Hook manipulation + +These functions provide convenient and thread-safe means of manipulating +hook variables. + +=cut +*/ + +/* +=for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p + +Puts a C function into the chain of check functions for a specified op +type. This is the preferred way to manipulate the L</PL_check> array. +I<opcode> specifies which type of op is to be affected. I<new_checker> +is a pointer to the C function that is to be added to that opcode's +check chain, and I<old_checker_p> points to the storage location where a +pointer to the next function in the chain will be stored. The value of +I<new_pointer> is written into the L</PL_check> 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<old_checker_p> should be defined like this: + + static Perl_check_t old_checker_p; + +L</PL_check> 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 +is idempotent. The location I<*old_checker_p> must initially (once +per process) contain a null pointer. A C variable of static duration +(declared at file scope, typically also marked C<static> to give +it internal linkage) will be implicitly initialised appropriately, +if it does not have an explicit initialiser. This function will only +actually modify the check chain if it finds I<*old_checker_p> to be null. +This function is also thread safe on the small scale. It uses appropriate +locking to avoid race conditions in accessing L</PL_check>. + +When this function is called, the function referenced by I<new_checker> +must be ready to be called, except for I<*old_checker_p> being unfilled. +In a threading situation, I<new_checker> may be called immediately, +even before this function has returned. I<*old_checker_p> will always +be appropriately set before I<new_checker> is called. If I<new_checker> +decides not to do anything special with an op that it is given (which +is the usual case for most uses of op check hooking), it must chain the +check function referenced by I<*old_checker_p>. + +If you want to influence compilation of calls to a specific subroutine, +then use L</cv_set_call_checker> rather than hooking checking of all +C<entersub> ops. + +=cut +*/ + +void +Perl_wrap_op_checker(pTHX_ Optype opcode, + Perl_check_t new_checker, Perl_check_t *old_checker_p) +{ + dVAR; + + PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_WRAP_OP_CHECKER; + if (*old_checker_p) return; + OP_CHECK_MUTEX_LOCK; + if (!*old_checker_p) { + *old_checker_p = PL_check[opcode]; + PL_check[opcode] = new_checker; + } + OP_CHECK_MUTEX_UNLOCK; +} + +#include "XSUB.h" + +/* Efficient sub that returns a constant scalar value. */ +static void +const_sv_xsub(pTHX_ CV* cv) +{ + dXSARGS; + SV *const sv = MUTABLE_SV(XSANY.any_ptr); + PERL_UNUSED_ARG(items); + if (!sv) { + XSRETURN(0); + } + EXTEND(sp, 1); + ST(0) = sv; + XSRETURN(1); +} + +static void +const_av_xsub(pTHX_ CV* cv) +{ + dXSARGS; + AV * const av = MUTABLE_AV(XSANY.any_ptr); + SP -= items; + assert(av); +#ifndef DEBUGGING + if (!av) { + XSRETURN(0); + } +#endif + if (SvRMAGICAL(av)) + Perl_croak(aTHX_ "Magical list constants are not supported"); + if (GIMME_V != G_ARRAY) { + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); + XSRETURN(1); + } + EXTEND(SP, AvFILLp(av)+1); + Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *); + XSRETURN(AvFILLp(av)+1); +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */