X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d5a02d973b44832f918778202d68f066c8af3963..HEAD:/op.c diff --git a/op.c b/op.c index 522b8d2..9029126 100644 --- a/op.c +++ b/op.c @@ -19,8 +19,8 @@ * [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. +/* This file contains the functions that create and manipulate the OP + * structures that hold a compiled perl program. * * Note that during the build of miniperl, a temporary copy of this file * is made, called opmini.c. @@ -167,7 +167,6 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #include "invlist_inline.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) static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar"; @@ -177,9 +176,11 @@ static const char array_passed_to_stat[] = "Array passed to stat will be coerced * first node in op_p. */ -STATIC void -S_prune_chain_head(OP** op_p) +void +Perl_op_prune_chain_head(OP** op_p) { + PERL_ARGS_ASSERT_OP_PRUNE_CHAIN_HEAD; + while (*op_p && ( (*op_p)->op_type == OP_NULL || (*op_p)->op_type == OP_SCOPE @@ -207,38 +208,51 @@ S_prune_chain_head(OP** op_p) /* 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))) + +#define DIFF(o,p) \ + (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \ + ((size_t)((I32 **)(p) - (I32**)(o)))) /* requires double parens and aTHX_ */ #define DEBUG_S_warn(args) \ DEBUG_S( \ - PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ + PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \ ) +/* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */ +#define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT))) + +/* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */ +#define OpSLABSizeBytes(sz) \ + ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots)) /* malloc a new op slab (suitable for attaching to PL_compcv). - * sz is in units of pointers */ + * sz is in units of pointers from the beginning of opslab_opslots */ static OPSLAB * S_new_slab(pTHX_ OPSLAB *head, size_t sz) { OPSLAB *slab; + size_t sz_bytes = OpSLABSizeBytes(sz); /* opslot_offset is only U16 */ - assert(sz < U16_MAX); + assert(sz < U16_MAX); + /* room for at least one op */ + assert(sz >= OPSLOT_SIZE_BASE); #ifdef PERL_DEBUG_READONLY_OPS - slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *), - PROT_READ|PROT_WRITE, - MAP_ANON|MAP_PRIVATE, -1, 0); + slab = (OPSLAB *) mmap(0, sz_bytes, + 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)); + (unsigned long) sz, slab)); if (slab == MAP_FAILED) { - perror("mmap failed"); - abort(); + perror("mmap failed"); + abort(); } #else - slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); + slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes); + Zero(slab, sz_bytes, char); #endif slab->opslab_size = (U16)sz; @@ -246,7 +260,7 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz) /* The context is unused in non-Windows */ PERL_UNUSED_CONTEXT; #endif - slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots); + slab->opslab_free_space = sz; slab->opslab_head = head ? head : slab; DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p", (unsigned int)slab->opslab_size, (void*)slab, @@ -254,6 +268,44 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz) return slab; } +#define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE) + +#define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o) +static void +S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) { + U16 sz = OpSLOT(o)->opslot_size; + U16 index = OPSLOT_SIZE_TO_INDEX(sz); + + assert(sz >= OPSLOT_SIZE_BASE); + /* make sure the array is large enough to include ops this large */ + if (!slab->opslab_freed) { + /* we don't have a free list array yet, make a new one */ + slab->opslab_freed_size = index+1; + slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*)); + + if (!slab->opslab_freed) + croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op")); + } + else if (index >= slab->opslab_freed_size) { + /* It's probably not worth doing exponential expansion here, the number of op sizes + is small. + */ + /* We already have a list that isn't large enough, expand it */ + size_t newsize = index+1; + OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*)); + + if (!p) + croak_no_mem_ext(STR_WITH_LEN("op:link_freed_op")); + + Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *); + + slab->opslab_freed = p; + slab->opslab_freed_size = newsize; + } + + o->op_next = slab->opslab_freed[index]; + slab->opslab_freed[index] = o; +} /* Returns a sz-sized block of memory (suitable for holding an op) from * a free slot in the chain of op slabs attached to PL_compcv. @@ -268,7 +320,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) OPSLAB *slab2; OPSLOT *slot; OP *o; - size_t opsz; + size_t sz_in_p; /* size in pointer units, including the OPSLOT header */ /* 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 @@ -279,7 +331,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) { - o = (OP*)PerlMemShared_calloc(1, sz); + o = (OP*)PerlMemShared_calloc(1, sz); goto gotit; } @@ -290,81 +342,77 @@ Perl_Slab_Alloc(pTHX_ size_t sz) allocated yet. See the commit message for 8be227ab5eaa23f2 for more details. */ if (!CvSTART(PL_compcv)) { - CvSTART(PL_compcv) = - (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE)); - CvSLABBED_on(PL_compcv); - head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ + CvSTART(PL_compcv) = + (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE)); + CvSLABBED_on(PL_compcv); + head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */ } else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt; - opsz = SIZE_TO_PSIZE(sz); - sz = opsz + OPSLOT_HEADER_P; + sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER); - /* The slabs maintain a free list of OPs. In particular, constant folding + /* The head slab for each CV maintains 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 (head_slab->opslab_freed) { - OP **too = &head_slab->opslab_freed; - o = *too; - DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p", - (void*)o, - (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset, - (void*)head_slab)); - - while (o && OpSLOT(o)->opslot_size < 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) { + if (head_slab->opslab_freed && + OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) { + U16 base_index; + + /* look for a large enough size with any freed ops */ + for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p); + base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index]; + ++base_index) { + } + + if (base_index < head_slab->opslab_freed_size) { + /* found a freed op */ + o = head_slab->opslab_freed[base_index]; + DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p", - (void*)o, - (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset, - (void*)head_slab)); - *too = o->op_next; - Zero(o, opsz, I32 *); - o->op_slabbed = 1; - goto gotit; - } + (void *)o, (void *)OpMySLAB(o), (void *)head_slab)); + head_slab->opslab_freed[base_index] = o->op_next; + Zero(o, sz, char); + o->op_slabbed = 1; + goto gotit; + } } #define INIT_OPSLOT(s) \ - slot->opslot_offset = DIFF(slab2, slot) ; \ - slot->opslot_size = s; \ - slab2->opslab_free_space -= s; \ - o = &slot->opslot_op; \ - o->op_slabbed = 1 + slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \ + slot->opslot_size = s; \ + slab2->opslab_free_space -= s; \ + o = &slot->opslot_op; \ + o->op_slabbed = 1 /* The partially-filled slab is next in the chain. */ slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab; - if (slab2->opslab_free_space < 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 (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) { - slot = &slab2->opslab_slots; - INIT_OPSLOT(slab2->opslab_free_space); - o->op_type = OP_FREED; - o->op_next = head_slab->opslab_freed; - head_slab->opslab_freed = o; - } - - /* Create a new slab. Make this one twice as big. */ - slab2 = S_new_slab(aTHX_ head_slab, - slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2 + if (slab2->opslab_free_space < sz_in_p) { + /* Remaining space is too small. */ + /* If we can fit a BASEOP, add it to the free chain, so as not + to waste it. */ + if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) { + slot = &slab2->opslab_slots; + INIT_OPSLOT(slab2->opslab_free_space); + o->op_type = OP_FREED; + DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p", + (void *)o, (void *)slab2, (void *)head_slab)); + link_freed_op(head_slab, o); + } + + /* Create a new slab. Make this one twice as big. */ + slab2 = S_new_slab(aTHX_ head_slab, + slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2 ? PERL_MAX_SLAB_SIZE : slab2->opslab_size * 2); - slab2->opslab_next = head_slab->opslab_next; - head_slab->opslab_next = slab2; + slab2->opslab_next = head_slab->opslab_next; + head_slab->opslab_next = slab2; } - assert(slab2->opslab_size >= sz); + assert(slab2->opslab_size >= sz_in_p); /* Create a new op slot */ - slot = (OPSLOT *) - ((I32 **)&slab2->opslab_slots - + slab2->opslab_free_space - sz); + slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p); assert(slot >= &slab2->opslab_slots); - INIT_OPSLOT(sz); + INIT_OPSLOT(sz_in_p); DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p", (void*)o, (void*)slab2, (void*)head_slab)); @@ -387,11 +435,11 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab) 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); + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n", + (unsigned long) slab->opslab_size, (void *)slab));*/ + if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ)) + Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab, + (unsigned long)slab->opslab_size, errno); } } @@ -405,13 +453,13 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) 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); - } + /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n", + (unsigned long) size, (void *)slab2));*/ + if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size), + PROT_READ|PROT_WRITE)) { + Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab, + (unsigned long)slab2->opslab_size, errno); + } } slab->opslab_readonly = 0; } @@ -420,13 +468,6 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) # 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 - /* make freed ops die if they're inadvertently executed */ #ifdef DEBUGGING static OP * @@ -455,31 +496,28 @@ Perl_Slab_Free(pTHX_ void *op) if (!o->op_slabbed) { if (!o->op_static) - PerlMemShared_free(op); - return; + 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; + link_freed_op(slab, o); DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p", - (void*)o, - (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset, - (void*)slab)); + (void*)o, (void *)OpMySLAB(o), (void*)slab)); OpslabREFCNT_dec_padok(slab); } void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) { - const bool havepad = !!PL_comppad; + const bool havepad = cBOOL(PL_comppad); PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { - ENTER; - PAD_SAVE_SETNULLPAD(); + ENTER; + PAD_SAVE_SETNULLPAD(); } opslab_free(slab); if (havepad) LEAVE; @@ -503,20 +541,21 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) PERL_UNUSED_CONTEXT; DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); assert(slab->opslab_refcnt == 1); + PerlMemShared_free(slab->opslab_freed); do { - slab2 = slab->opslab_next; + slab2 = slab->opslab_next; #ifdef DEBUGGING - slab->opslab_refcnt = ~(size_t)0; + 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(); - } + DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", + (void*)slab)); + if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) { + perror("munmap failed"); + abort(); + } #else - PerlMemShared_free(slab); + PerlMemShared_free(slab); #endif slab = slab2; } while (slab); @@ -536,34 +575,32 @@ Perl_opslab_force_free(pTHX_ OPSLAB *slab) PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; slab2 = slab; do { - OPSLOT *slot = (OPSLOT*) - ((I32**)&slab2->opslab_slots + slab2->opslab_free_space); - OPSLOT *end = (OPSLOT*) - ((I32**)slab2 + slab2->opslab_size); - for (; slot < end; + OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space); + OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size); + for (; slot < end; slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) ) { - if (slot->opslot_op.op_type != OP_FREED - && !(slot->opslot_op.op_savefree + if (slot->opslot_op.op_type != OP_FREED + && !(slot->opslot_op.op_savefree #ifdef DEBUGGING - && ++savestack_count + && ++savestack_count #endif - ) - ) { - assert(slot->opslot_op.op_slabbed); - op_free(&slot->opslot_op); - if (slab->opslab_refcnt == 1) goto free; - } - } + ) + ) { + 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); + assert(savestack_count == slab->opslab_refcnt-1); #endif - /* Remove the CV’s reference count. */ - slab->opslab_refcnt--; - return; + /* Remove the CV’s reference count. */ + slab->opslab_refcnt--; + return; } free: opslab_free(slab); @@ -612,25 +649,19 @@ Perl_op_refcnt_dec(pTHX_ OP *o) #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 ) \ + 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))); + OP_DESC(o))); return o; } @@ -657,11 +688,9 @@ 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); + (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) { @@ -669,86 +698,109 @@ S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) 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)); + (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } -STATIC void -S_no_bareword_allowed(pTHX_ OP *o) +void +Perl_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))); + "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", + SVfARG(cSVOPo_sv))); o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ } +void +Perl_no_bareword_filehandle(pTHX_ const char *fhname) { + PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE; + + if (strNE(fhname, "STDERR") + && strNE(fhname, "STDOUT") + && strNE(fhname, "STDIN") + && strNE(fhname, "_") + && strNE(fhname, "ARGV") + && strNE(fhname, "ARGVOUT") + && strNE(fhname, "DATA")) { + qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname)); + } +} + /* "register" allocation */ PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { PADOFFSET off; + bool is_idfirst, is_default; 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); + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); + + is_idfirst = flags & SVf_UTF8 + ? isIDFIRST_utf8_safe((U8*)name + 1, name + len) + : isIDFIRST_A(name[1]); + + /* $_, @_, etc. */ + is_default = len == 2 && name[1] == '_'; /* complain about "my $" etc etc */ - if ( len - && !( is_our - || isALPHA(name[1]) - || ( (flags & SVf_UTF8) - && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) - || (name[1] == '_' && len > 2))) - { + if (!is_our && (!is_idfirst || is_default)) { const char * const type = PL_parser->in_my == KEY_sigvar ? "subroutine signature" : PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\""; - if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) - && isASCII(name[1]) - && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) { - /* diag_listed_as: Can't use global %s in %s */ - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s", - name[0], toCTRL(name[1]), + if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) + && isASCII(name[1]) + && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) { + /* diag_listed_as: Can't use global %s in %s */ + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, - type)); - } else { - yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s", + type)); + } else { + yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s", (int) len, name, - type), flags & SVf_UTF8); - } + type), flags & SVf_UTF8); + } } /* 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 - ) + U32 addflags = 0; + if(is_our) + addflags |= padadd_OUR; + else if(PL_parser->in_my == KEY_state) + addflags |= padadd_STATE; + else if(PL_parser->in_my == KEY_field) + addflags |= padadd_FIELD; + + off = pad_add_name_pvn(name, len, addflags, + 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); + CvCLONE_on(PL_compcv); return off; } /* -=head1 Optree Manipulation Functions +=for apidoc_section $optree_manipulation =for apidoc alloccopstash @@ -770,15 +822,15 @@ Perl_alloccopstash(pTHX_ HV *hv) 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 (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; + 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; @@ -803,13 +855,21 @@ S_op_destroy(pTHX_ OP *o) Free an op and its children. Only use this when an op is no longer linked to from any optree. +Remember that any op with C set is expected to have a valid +C pointer. If you are attempting to free an op but preserve its +child op, make sure to clear that flag before calling C. For +example: + + OP *kid = o->op_first; o->op_first = NULL; + o->op_flags &= ~OPf_KIDS; + op_free(o); + =cut */ void Perl_op_free(pTHX_ OP *o) { - dVAR; OPCODE type; OP *top_op = o; OP *next_op = o; @@ -853,6 +913,12 @@ Perl_op_free(pTHX_ OP *o) /* free child ops before ourself, (then free ourself "on the * way back up") */ + /* Ensure the caller maintains the relationship between OPf_KIDS and + * op_first != NULL when restructuring the tree + * https://github.com/Perl/perl5/issues/20764 + */ + assert(!(o->op_flags & OPf_KIDS) || cUNOPo->op_first); + if (!went_up && o->op_flags & OPf_KIDS) { next_op = cUNOPo->op_first; continue; @@ -889,11 +955,15 @@ Perl_op_free(pTHX_ OP *o) * 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, only - * evaled/required code */ + * evaled/required code; + * * it's a banned op - we may be croaking before the op is + * fully formed. - see CHECKOP. */ #ifdef DEBUGGING if ( o->op_ppaddr == PL_ppaddr[type] && PL_parser - && !PL_parser->error_count) + && !PL_parser->error_count + && !(PL_op_mask && PL_op_mask[type]) + ) { assert(!(o->op_private & ~PL_op_private_valid[type])); } @@ -983,7 +1053,6 @@ void Perl_op_clear(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_OP_CLEAR; @@ -993,12 +1062,12 @@ Perl_op_clear(pTHX_ OP *o) case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ case OP_ARGDEFELEM: /* Was holding signature index. */ - o->op_targ = 0; - break; + o->op_targ = 0; + break; default: - if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type)) - break; - /* FALLTHROUGH */ + if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type)) + break; + /* FALLTHROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: @@ -1007,23 +1076,23 @@ Perl_op_clear(pTHX_ OP *o) #else S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv)); #endif - break; + 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; - } + if (cMETHOPo->op_rclass_targ) { + pad_swipe(cMETHOPo->op_rclass_targ, 1); + cMETHOPo->op_rclass_targ = 0; + } #else - SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); - cMETHOPx(o)->op_rclass_sv = NULL; + SvREFCNT_dec(cMETHOPo->op_rclass_sv); + cMETHOPo->op_rclass_sv = NULL; #endif /* FALLTHROUGH */ 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; + SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv); + cMETHOPo->op_u.op_meth_sv = NULL; #ifdef USE_ITHREADS if (o->op_targ) { pad_swipe(o->op_targ, 1); @@ -1033,52 +1102,52 @@ Perl_op_clear(pTHX_ OP *o) break; case OP_CONST: case OP_HINTSEVAL: - SvREFCNT_dec(cSVOPo->op_sv); - cSVOPo->op_sv = NULL; + 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. - **/ + /** 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; + 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 */ + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; + /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: - if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) + if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) && (o->op_private & OPpTRANS_USE_SVOP)) { #ifdef USE_ITHREADS - if (cPADOPo->op_padix > 0) { - pad_swipe(cPADOPo->op_padix, TRUE); - cPADOPo->op_padix = 0; - } + 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; + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = NULL; #endif - } - else { - PerlMemShared_free(cPVOPo->op_pv); - cPVOPo->op_pv = NULL; - } - break; + } + else { + PerlMemShared_free(cPVOPo->op_pv); + cPVOPo->op_pv = NULL; + } + break; case OP_SUBST: - op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); - goto clear_pmop; + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); + goto clear_pmop; case OP_SPLIT: if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */ @@ -1093,15 +1162,15 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif } - /* FALLTHROUGH */ + /* 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; + 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 @@ -1109,19 +1178,19 @@ Perl_op_clear(pTHX_ OP *o) * 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; + 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)); + sizeof(offset)); } #else - ReREFCNT_dec(PM_GETRE(cPMOPo)); - PM_SETRE(cPMOPo, NULL); + ReREFCNT_dec(PM_GETRE(cPMOPo)); + PM_SETRE(cPMOPo, NULL); #endif - break; + break; case OP_ARGCHECK: PerlMemShared_free(cUNOP_AUXo->op_aux); @@ -1250,11 +1319,27 @@ Perl_op_clear(pTHX_ OP *o) PerlMemShared_free(cUNOP_AUXo->op_aux - 1); } break; + + case OP_METHSTART: + { + UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; + /* Every item in aux is a UV, so nothing in it to free */ + Safefree(aux); + } + break; + + case OP_INITFIELD: + { + UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; + /* Every item in aux is a UV, so nothing in it to free */ + Safefree(aux); + } + break; } if (o->op_targ > 0) { - pad_free(o->op_targ); - o->op_targ = 0; + pad_free(o->op_targ); + o->op_targ = 0; } } @@ -1263,9 +1348,27 @@ S_cop_free(pTHX_ COP* cop) { PERL_ARGS_ASSERT_COP_FREE; + /* If called during global destruction PL_defstash might be NULL and there + shouldn't be any code running that will trip over the bad cop address. + This also avoids uselessly creating the AV after it's been destroyed. + */ + if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) { + /* Remove the now invalid op from the line number information. + This could cause a freed memory overwrite if the debugger tried to + set a breakpoint on this line. + */ + AV *av = CopFILEAVn(cop); + if (av) { + SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE); + if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) { + SvIV_set(*svp, 0); + } + } + } CopFILE_free(cop); if (! specialWARN(cop->cop_warnings)) - PerlMemShared_free(cop->cop_warnings); + cop->cop_warnings = rcpv_free(cop->cop_warnings); + cophh_free(CopHINTHASH_get(cop)); if (PL_curcop == cop) PL_curcop = NULL; @@ -1279,31 +1382,31 @@ S_forget_pmop(pTHX_ PMOP *const 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; - } - } - } + 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; + PL_curpm = NULL; } @@ -1320,7 +1423,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) case OP_SPLIT: case OP_MATCH: case OP_QR: - forget_pmop((PMOP*)o); + forget_pmop(cPMOPo); } if (o->op_flags & OPf_KIDS) { @@ -1353,35 +1456,44 @@ other ops. void Perl_op_null(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_OP_NULL; if (o->op_type == OP_NULL) - return; + return; op_clear(o); o->op_targ = o->op_type; OpTYPE_set(o, OP_NULL); } +/* +=for apidoc op_refcnt_lock + +Implements the C macro which you should use instead. + +=cut +*/ + void Perl_op_refcnt_lock(pTHX) PERL_TSA_ACQUIRE(PL_op_mutex) { -#ifdef USE_ITHREADS - dVAR; -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } +/* +=for apidoc op_refcnt_unlock + +Implements the C macro which you should use instead. + +=cut +*/ + void Perl_op_refcnt_unlock(pTHX) PERL_TSA_RELEASE(PL_op_mutex) { -#ifdef USE_ITHREADS - dVAR; -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } @@ -1395,7 +1507,7 @@ op_sibling nodes. By analogy with the perl-level C 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 +children. The last deleted node will be marked 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 @@ -1592,7 +1704,6 @@ S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) LOGOP * Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) { - dVAR; LOGOP *logop; OP *kid = first; NewOp(1101, logop, 1, LOGOP); @@ -1615,7 +1726,7 @@ Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) =for apidoc op_contextualize Applies a syntactic context to an op tree representing an expression. -C is the op tree, and C must be C, C, +C is the op tree, and C must be C, C, or C to specify the context to apply. The modified op tree is returned. @@ -1627,12 +1738,12 @@ 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); + case G_SCALAR: return scalar(o); + case G_LIST: return list(o); + case G_VOID: return scalarvoid(o); + default: + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); } } @@ -1703,7 +1814,7 @@ 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); + scalar(kid); } return o; } @@ -1718,17 +1829,17 @@ S_scalarboolean(pTHX_ OP *o) (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN && cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST && !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) { - if (ckWARN(WARN_SYNTAX)) { - const line_t oldline = CopLINE(PL_curcop); + 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 + 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); + CopLINE_set(PL_curcop, PL_parser->copline); } - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); - CopLINE_set(PL_curcop, oldline); - } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); + CopLINE_set(PL_curcop, oldline); + } } return scalar(o); } @@ -1738,121 +1849,96 @@ S_op_varname_subscript(pTHX_ const OP *o, int subscript_type) { assert(o); assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || - o->op_type == OP_PADHV || o->op_type == OP_RV2HV); + 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, subscript_type); - } - return - varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); + 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, subscript_type); + } + return + varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); } } -static SV * -S_op_varname(pTHX_ const OP *o) +SV * +Perl_op_varname(pTHX_ const OP *o) { + PERL_ARGS_ASSERT_OP_VARNAME; + return S_op_varname_subscript(aTHX_ o, 1); } -static void -S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) -{ /* or not so pretty :-) */ - 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) +Warns that an access of a single element from a named container variable in +scalar context might not be what the programmer wanted. The container +variable's (sigiled, full) name is given by C, and the key to access +it is given by the C of the C op given by C. +C selects whether it prints using {KEY} or [KEY] brackets. + +C selects between two different messages used in different places. + */ +void +Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice) { - OP *kid; - const bool h = o->op_type == OP_HSLICE - || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); - const char lbrack = - h ? '{' : '['; - const char rbrack = - h ? '}' : ']'; - 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; + PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT; - 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: - return; - } - - /* Don't warn if we have a nulled list either. */ - if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) - return; + SV *keysv = NULL; + const char *keypv = NULL; + + const char lbrack = is_hash ? '{' : '['; + const char rbrack = is_hash ? '}' : ']'; + + if (o->op_type == OP_CONST) { + keysv = cSVOPo_sv; + if (SvPOK(keysv)) { + SV *sv = keysv; + keysv = sv_newmortal(); + pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT); + } + else if (!SvOK(keysv)) + keypv = "undef"; + } + else keypv = "..."; - 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); -} + const char *msg; + + if (keypv) { + msg = is_slice ? + /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ + PERL_DIAG_WARN_SYNTAX( + "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") : + /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ + PERL_DIAG_WARN_SYNTAX( + "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c"); + + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg, + SVfARG(name), lbrack, keypv, rbrack, + SVfARG(name), lbrack, keypv, rbrack); + } + else { + msg = is_slice ? + /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ + PERL_DIAG_WARN_SYNTAX( + "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") : + /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ + PERL_DIAG_WARN_SYNTAX( + "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c"); + + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg, + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); + } +} /* apply scalar context to the o subtree */ @@ -1953,18 +2039,14 @@ Perl_scalar(pTHX_ OP *o) break; case OP_SORT: - Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); + Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort"); 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) @@ -1975,26 +2057,10 @@ Perl_scalar(pTHX_ OP *o) kid = cLISTOPo->op_first; kid = OpSIBLING(kid); /* get past pushmark */ assert(OpSIBLING(kid)); - name = S_op_varname(aTHX_ OpSIBLING(kid)); + name = op_varname(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); + warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false); } } /* switch */ @@ -2031,7 +2097,6 @@ Perl_scalar(pTHX_ OP *o) OP * Perl_scalarvoid(pTHX_ OP *arg) { - dVAR; OP *kid; SV* sv; OP *o = arg; @@ -2059,14 +2124,6 @@ Perl_scalarvoid(pTHX_ OP *arg) goto get_next_op; } - 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. */ - goto get_next_op; - } - o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { @@ -2080,11 +2137,11 @@ Perl_scalarvoid(pTHX_ OP *arg) if (o->op_type == OP_REPEAT) scalar(cBINOPo->op_first); goto func_ops; - case OP_CONCAT: + case OP_CONCAT: if ((o->op_flags & OPf_STACKED) && - !(o->op_private & OPpCONCAT_NESTED)) + !(o->op_private & OPpCONCAT_NESTED)) break; - goto func_ops; + goto func_ops; case OP_SUBSTR: if (o->op_private == 4) break; @@ -2096,6 +2153,7 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_REF: case OP_REFGEN: case OP_SREFGEN: + case OP_ANONCODE: case OP_DEFINED: case OP_HEX: case OP_OCT: @@ -2152,6 +2210,14 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_PROTOTYPE: case OP_RUNCV: func_ops: + if ( (PL_opargs[o->op_type] & OA_TARGLEX) + && (o->op_private & OPpTARGET_MY) + ) + /* '$lex = $a + $b' etc is optimised to '$a + $b' but + * where the add op's TARG is actually $lex. So it's not + * useless to be in void context in this special case */ + break; + useless = OP_DESC(o); break; @@ -2265,17 +2331,17 @@ Perl_scalarvoid(pTHX_ OP *arg) if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2) break; - rv2gv = ((BINOP *)o)->op_last; + rv2gv = cBINOPo->op_last; if (!rv2gv || rv2gv->op_type != OP_RV2GV) break; - refgen = (UNOP *)((BINOP *)o)->op_first; + refgen = cUNOPx(cBINOPo->op_first); if (!refgen || (refgen->op_type != OP_REFGEN && refgen->op_type != OP_SREFGEN)) break; - exlist = (LISTOP *)refgen->op_first; + exlist = cLISTOPx(refgen->op_first); if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; @@ -2284,7 +2350,7 @@ Perl_scalarvoid(pTHX_ OP *arg) && exlist->op_first != exlist->op_last) break; - rv2cv = (UNOP*)exlist->op_last; + rv2cv = cUNOPx(exlist->op_last); if (rv2cv->op_type != OP_RV2CV) break; @@ -2344,6 +2410,7 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_LINESEQ: case OP_LEAVEGIVEN: case OP_LEAVEWHEN: + case OP_ONCE: kids: next_kid = cLISTOPo->op_first; break; @@ -2373,6 +2440,12 @@ Perl_scalarvoid(pTHX_ OP *arg) case OP_SCALAR: scalar(o); break; + case OP_EMPTYAVHV: + if (!(o->op_private & OPpTARGET_MY)) + useless = (o->op_private & OPpEMPTYAVHV_IS_HV) ? + "anonymous hash ({})" : + "anonymous array ([])"; + break; } if (useless_sv) { @@ -2402,8 +2475,7 @@ Perl_scalarvoid(pTHX_ OP *arg) } o = next_kid; } - - return arg; + NOT_REACHED; } @@ -2412,8 +2484,8 @@ 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); + for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) + list(kid); } return o; } @@ -2564,34 +2636,40 @@ Perl_list(pTHX_ OP *o) } /* while */ } +/* apply void context to non-final ops of a sequence */ static OP * -S_scalarseq(pTHX_ OP *o) +S_voidnonfinal(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; + const OPCODE type = o->op_type; + + if (type == OP_LINESEQ || type == OP_SCOPE || + type == OP_LEAVE || type == OP_LEAVETRY) + { + OP *kid = cLISTOPo->op_first, *sib; + if(type == OP_LEAVE) { + /* Don't put the OP_ENTER in void context */ + assert(kid->op_type == OP_ENTER); + kid = OpSIBLING(kid); + } + for (; 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); + o = newOP(OP_STUB, 0); return o; } @@ -2601,7 +2679,7 @@ 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); + op_lvalue(kid, type); } return o; } @@ -2614,8 +2692,8 @@ S_modkids(pTHX_ OP *o, I32 type) * real if false, only check (and possibly croak); don't update op */ -STATIC void -S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) +void +Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) { PADNAME *lexname; GV **fields; @@ -2625,13 +2703,13 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) if (rop) { if (rop->op_first->op_type == OP_PADSV) /* @$hash{qw(keys here)} */ - rop = (UNOP*)rop->op_first; + rop = cUNOPx(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; + rop = cUNOPx(cLISTOPx(rop->op_first)->op_last); } else rop = NULL; @@ -2644,11 +2722,11 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) check_fields = rop && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ), - SvPAD_TYPED(lexname)) + PadnameHasTYPE(lexname)) && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE)) && isGV(*fields) && GvHV(*fields); - for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) { + for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) { SV **svp, *sv; if (key_op->op_type != OP_CONST) continue; @@ -2670,7 +2748,11 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) { SSize_t keylen; const char * const key = SvPV_const(sv, *(STRLEN*)&keylen); - SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0); + if (keylen > I32_MAX) { + Perl_croak_nocontext("Sorry, hash keys must be smaller than 2**31 bytes"); + } + + SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, 0); SvREFCNT_dec_NN(sv); *svp = nsv; } @@ -2686,2433 +2768,1195 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real) } } -/* info returned by S_sprintf_is_multiconcatable() */ - -struct sprintf_ismc_info { - SSize_t nargs; /* num of args to sprintf (not including the format) */ - char *start; /* start of raw format string */ - char *end; /* bytes after end of raw format string */ - STRLEN total_len; /* total length (in bytes) of format string, not - including '%s' and half of '%%' */ - STRLEN variant; /* number of bytes by which total_len_p would grow - if upgraded to utf8 */ - bool utf8; /* whether the format is utf8 */ -}; - -/* is the OP_SPRINTF o suitable for converting into a multiconcat op? - * i.e. its format argument is a const string with only '%s' and '%%' - * formats, and the number of args is known, e.g. - * sprintf "a=%s f=%s", $a[0], scalar(f()); - * but not - * sprintf "i=%d a=%s f=%s", $i, @a, f(); - * - * If successful, the sprintf_ismc_info struct pointed to by info will be - * populated. +/* do all the final processing on an optree (e.g. running the peephole + * optimiser on it), then attach it to cv (if cv is non-null) */ -STATIC bool -S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info) +static void +S_process_optree(pTHX_ CV *cv, OP *optree, OP* start) { - OP *pm, *constop, *kid; - SV *sv; - char *s, *e, *p; - SSize_t nargs, nformats; - STRLEN cur, total_len, variant; - bool utf8; - - /* if sprintf's behaviour changes, die here so that someone - * can decide whether to enhance this function or skip optimising - * under those new circumstances */ - assert(!(o->op_flags & OPf_STACKED)); - assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX)); - assert(!(o->op_private & ~OPpARG4_MASK)); - - pm = cUNOPo->op_first; - if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */ - return FALSE; - constop = OpSIBLING(pm); - if (!constop || constop->op_type != OP_CONST) - return FALSE; - sv = cSVOPx_sv(constop); - if (SvMAGICAL(sv) || !SvPOK(sv)) - return FALSE; - - s = SvPV(sv, cur); - e = s + cur; + OP **startp; - /* Scan format for %% and %s and work out how many %s there are. - * Abandon if other format types are found. - */ + /* XXX for some reason, evals, require and main optrees are + * never attached to their CV; instead they just hang off + * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start + * and get manually freed when appropriate */ + if (cv) + startp = &CvSTART(cv); + else + startp = PL_in_eval? &PL_eval_start : &PL_main_start; - nformats = 0; - total_len = 0; - variant = 0; + *startp = start; + optree->op_private |= OPpREFCOUNTED; + OpREFCNT_set(optree, 1); + optimize_optree(optree); + CALL_PEEP(*startp); + finalize_optree(optree); + op_prune_chain_head(startp); - for (p = s; p < e; p++) { - if (*p != '%') { - total_len++; - if (!UTF8_IS_INVARIANT(*p)) - variant++; - continue; - } - p++; - if (p >= e) - return FALSE; /* lone % at end gives "Invalid conversion" */ - if (*p == '%') - total_len++; - else if (*p == 's') - nformats++; - else - return FALSE; + if (cv) { + /* now that optimizer has done its work, adjust pad values */ + pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT + : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); } +} - if (!nformats || nformats > PERL_MULTICONCAT_MAXARG) - return FALSE; - - utf8 = cBOOL(SvUTF8(sv)); - if (utf8) - variant = 0; - - /* scan args; they must all be in scalar cxt */ - - nargs = 0; - kid = OpSIBLING(constop); +#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. */ +void +Perl_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 - while (kid) { - if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR) - return FALSE; - nargs++; - kid = OpSIBLING(kid); +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); } - - if (nargs != nformats) - return FALSE; /* e.g. sprintf("%s%s", $a); */ - - - info->nargs = nargs; - info->start = s; - info->end = e; - info->total_len = total_len; - info->variant = variant; - info->utf8 = utf8; - - return TRUE; } - - -/* S_maybe_multiconcat(): - * - * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly - * convert it (and its children) into an OP_MULTICONCAT. See the code - * comments just before pp_multiconcat() for the full details of what - * OP_MULTICONCAT supports. - * - * Basically we're looking for an optree with a chain of OP_CONCATS down - * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or - * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g. - * - * $x = "$a$b-$c" - * - * looks like - * - * SASSIGN - * | - * STRINGIFY -- PADSV[$x] - * | - * | - * ex-PUSHMARK -- CONCAT/S - * | - * CONCAT/S -- PADSV[$d] - * | - * CONCAT -- CONST["-"] - * | - * PADSV[$a] -- PADSV[$b] - * - * Note that at this stage the OP_SASSIGN may have already been optimised - * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT. - */ - -STATIC void -S_maybe_multiconcat(pTHX_ OP *o) +static bool +S_vivifies(const OPCODE type) { - dVAR; - OP *lastkidop; /* the right-most of any kids unshifted onto o */ - OP *topop; /* the top-most op in the concat tree (often equals o, - unless there are assign/stringify ops above it */ - OP *parentop; /* the parent op of topop (or itself if no parent) */ - OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */ - OP *targetop; /* the op corresponding to target=... or target.=... */ - OP *stringop; /* the OP_STRINGIFY op, if any */ - OP *nextop; /* used for recreating the op_next chain without consts */ - OP *kid; /* general-purpose op pointer */ - UNOP_AUX_item *aux; - UNOP_AUX_item *lenp; - char *const_str, *p; - struct sprintf_ismc_info sprintf_info; - - /* store info about each arg in args[]; - * toparg is the highest used slot; argp is a general - * pointer to args[] slots */ - struct { - void *p; /* initially points to const sv (or null for op); - later, set to SvPV(constsv), with ... */ - STRLEN len; /* ... len set to SvPV(..., len) */ - } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1]; - - SSize_t nargs = 0; - SSize_t nconst = 0; - SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */ - STRLEN variant; - bool utf8 = FALSE; - bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op; - the last-processed arg will the LHS of one, - as args are processed in reverse order */ - U8 stacked_last = 0; /* whether the last seen concat op was STACKED */ - STRLEN total_len = 0; /* sum of the lengths of the const segments */ - U8 flags = 0; /* what will become the op_flags and ... */ - U8 private_flags = 0; /* ... op_private of the multiconcat op */ - bool is_sprintf = FALSE; /* we're optimising an sprintf */ - bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */ - bool prev_was_const = FALSE; /* previous arg was a const */ - - /* ----------------------------------------------------------------- - * Phase 1: - * - * Examine the optree non-destructively to determine whether it's - * suitable to be converted into an OP_MULTICONCAT. Accumulate - * information about the optree in args[]. - */ + 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; +} - argp = args; - targmyop = NULL; - targetop = NULL; - stringop = NULL; - topop = o; - parentop = o; - assert( o->op_type == OP_SASSIGN - || o->op_type == OP_CONCAT - || o->op_type == OP_SPRINTF - || o->op_type == OP_STRINGIFY); +/* apply lvalue reference (aliasing) context to the optree o. + * E.g. in + * \($x,$y) = (...) + * o would be the list ($x,$y) and type would be OP_AASSIGN. + * It may descend and apply this to children too, for example in + * \( $cond ? $x, $y) = (...) + */ - Zero(&sprintf_info, 1, struct sprintf_ismc_info); +static void +S_lvref(pTHX_ OP *o, I32 type) +{ + OP *kid; + OP * top_op = o; - /* first see if, at the top of the tree, there is an assign, - * append and/or stringify */ + while (1) { + switch (o->op_type) { + case OP_COND_EXPR: + o = OpSIBLING(cUNOPo->op_first); + continue; - if (topop->op_type == OP_SASSIGN) { - /* expr = ..... */ - if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN]) - return; - if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV)) - return; - assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */ + case OP_PUSHMARK: + goto do_next; - parentop = topop; - topop = cBINOPo->op_first; - targetop = OpSIBLING(topop); - if (!targetop) /* probably some sort of syntax error */ - 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")); + goto do_next; + } + slurpy: + OpTYPE_set(o, OP_LVAVREF); + o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; + o->op_flags |= OPf_MOD|OPf_REF; + goto do_next; + } + o->op_private |= OPpLVREF_AV; + goto checkgv; - /* don't optimise away assign in 'local $foo = ....' */ - if ( (targetop->op_private & OPpLVAL_INTRO) - /* these are the common ops which do 'local', but - * not all */ - && ( targetop->op_type == OP_GVSV - || targetop->op_type == OP_RV2SV - || targetop->op_type == OP_AELEM - || targetop->op_type == OP_HELEM - ) - ) - return; - } - else if ( topop->op_type == OP_CONCAT - && (topop->op_flags & OPf_STACKED) - && (!(topop->op_private & OPpCONCAT_NESTED)) - ) - { - /* expr .= ..... */ + 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")); + goto do_next; + } + 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; - /* OPpTARGET_MY shouldn't be able to be set here. If it is, - * decide what to do about it */ - assert(!(o->op_private & OPpTARGET_MY)); + 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; - /* barf on unknown flags */ - assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY))); - private_flags |= OPpMULTICONCAT_APPEND; - targetop = cBINOPo->op_first; - parentop = topop; - topop = OpSIBLING(targetop); + 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; - /* $x .= gets optimised to rcatline instead */ - if (topop->op_type == OP_READLINE) - return; - } + case OP_AELEM: + case OP_HELEM: + o->op_private |= OPpLVREF_ELEM; + o->op_flags |= OPf_STACKED; + break; - if (targetop) { - /* Can targetop (the LHS) if it's a padsv, be be optimised - * away and use OPpTARGET_MY instead? - */ - if ( (targetop->op_type == OP_PADSV) - && !(targetop->op_private & OPpDEREF) - && !(targetop->op_private & OPpPAD_STATE) - /* we don't support 'my $x .= ...' */ - && ( o->op_type == OP_SASSIGN - || !(targetop->op_private & OPpLVAL_INTRO)) - ) - is_targable = TRUE; - } + case OP_ASLICE: + case OP_HSLICE: + OpTYPE_set(o, OP_LVREFSLICE); + o->op_private &= OPpLVAL_INTRO; + goto do_next; - if (topop->op_type == OP_STRINGIFY) { - if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY]) - return; - stringop = topop; + case OP_NULL: + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto badref; + else if (!(o->op_flags & OPf_KIDS)) + goto do_next; - /* barf on unknown flags */ - assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY))); + /* the code formerly only recursed into the first child of + * a non ex-list OP_NULL. if we ever encounter such a null op with + * more than one child, need to decide whether its ok to process + * *all* its kids or not */ + assert(o->op_targ == OP_LIST + || !(OpHAS_SIBLING(cBINOPo->op_first))); + /* FALLTHROUGH */ + case OP_LIST: + o = cLISTOPo->op_first; + continue; - if ((topop->op_private & OPpTARGET_MY)) { - if (o->op_type == OP_SASSIGN) - return; /* can't have two assigns */ - targmyop = topop; + case OP_STUB: + if (o->op_flags & OPf_PARENS) + goto do_next; + /* 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])); + goto do_next; } - private_flags |= OPpMULTICONCAT_STRINGIFY; - parentop = topop; - topop = cBINOPx(topop)->op_first; - assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK)); - topop = OpSIBLING(topop); - } + 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; - if (topop->op_type == OP_SPRINTF) { - if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF]) - return; - if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) { - nargs = sprintf_info.nargs; - total_len = sprintf_info.total_len; - variant = sprintf_info.variant; - utf8 = sprintf_info.utf8; - is_sprintf = TRUE; - private_flags |= OPpMULTICONCAT_FAKE; - toparg = argp; - /* we have an sprintf op rather than a concat optree. - * Skip most of the code below which is associated with - * processing that optree. We also skip phase 2, determining - * whether its cost effective to optimise, since for sprintf, - * multiconcat is *always* faster */ - goto create_aux; + do_next: + while (1) { + if (o == top_op) + return; /* at top; no parents/siblings to try */ + if (OpHAS_SIBLING(o)) { + o = o->op_sibparent; + break; + } + o = o->op_sibparent; /*try parent's next sibling */ } - /* note that even if the sprintf itself isn't multiconcatable, - * the expression as a whole may be, e.g. in - * $x .= sprintf("%d",...) - * the sprintf op will be left as-is, but the concat/S op may - * be upgraded to multiconcat - */ - } - else if (topop->op_type == OP_CONCAT) { - if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT]) - return; + } /* while */ +} - if ((topop->op_private & OPpTARGET_MY)) { - if (o->op_type == OP_SASSIGN || targmyop) - return; /* can't have two assigns */ - targmyop = topop; - } - } - /* Is it safe to convert a sassign/stringify/concat op into - * a multiconcat? */ - assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP); - assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP); - assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP); - assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP); - STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last) - == STRUCT_OFFSET(UNOP_AUX, op_aux)); - STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last) - == STRUCT_OFFSET(UNOP_AUX, op_aux)); - - /* Now scan the down the tree looking for a series of - * CONCAT/OPf_STACKED ops on the LHS (with the last one not - * stacked). For example this tree: - * - * | - * CONCAT/STACKED - * | - * CONCAT/STACKED -- EXPR5 - * | - * CONCAT/STACKED -- EXPR4 - * | - * CONCAT -- EXPR3 - * | - * EXPR1 -- EXPR2 - * - * corresponds to an expression like - * - * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5) - * - * Record info about each EXPR in args[]: in particular, whether it is - * a stringifiable OP_CONST and if so what the const sv is. - * - * The reason why the last concat can't be STACKED is the difference - * between - * - * ((($a .= $a) .= $a) .= $a) .= $a - * - * and - * $a . $a . $a . $a . $a - * - * The main difference between the optrees for those two constructs - * is the presence of the last STACKED. As well as modifying $a, - * the former sees the changed $a between each concat, so if $s is - * initially 'a', the first returns 'a' x 16, while the latter returns - * 'a' x 5. And pp_multiconcat can't handle that kind of thing. - */ +PERL_STATIC_INLINE bool +S_potential_mod_type(I32 type) +{ + /* Types that only potentially result in modification. */ + return type == OP_GREPSTART || type == OP_ENTERSUB + || type == OP_REFGEN || type == OP_LEAVESUBLV; +} - kid = topop; - for (;;) { - OP *argop; - SV *sv; - bool last = FALSE; +/* +=for apidoc op_lvalue - if ( kid->op_type == OP_CONCAT - && !kid_is_last - ) { - OP *k1, *k2; - k1 = cUNOPx(kid)->op_first; - k2 = OpSIBLING(k1); - /* shouldn't happen except maybe after compile err? */ - if (!k2) - return; +Propagate lvalue ("modifiable") context to an op and its children. +C represents the context type, roughly based on the type of op that +would do the modifying, although C is represented by C, +because it has no op type of its own (it is signalled by a flag on +the lvalue op). - /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */ - if (kid->op_private & OPpTARGET_MY) - kid_is_last = TRUE; +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 C and a C argument of C. - stacked_last = (kid->op_flags & OPf_STACKED); - if (!stacked_last) - kid_is_last = TRUE; +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>. - kid = k1; - argop = k2; - } - else { - argop = kid; - last = TRUE; - } +=cut - if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2 - || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2) - { - /* At least two spare slots are needed to decompose both - * concat args. If there are no slots left, continue to - * examine the rest of the optree, but don't push new values - * on args[]. If the optree as a whole is legal for conversion - * (in particular that the last concat isn't STACKED), then - * the first PERL_MULTICONCAT_MAXARG elements of the optree - * can be converted into an OP_MULTICONCAT now, with the first - * child of that op being the remainder of the optree - - * which may itself later be converted to a multiconcat op - * too. - */ - if (last) { - /* the last arg is the rest of the optree */ - argp++->p = NULL; - nargs++; - } - } - else if ( argop->op_type == OP_CONST - && ((sv = cSVOPx_sv(argop))) - /* defer stringification until runtime of 'constant' - * things that might stringify variantly, e.g. the radix - * point of NVs, or overloaded RVs */ - && (SvPOK(sv) || SvIOK(sv)) - && (!SvGMAGICAL(sv)) - ) { - if (argop->op_private & OPpCONST_STRICT) - no_bareword_allowed(argop); - argp++->p = sv; - utf8 |= cBOOL(SvUTF8(sv)); - nconst++; - if (prev_was_const) - /* this const may be demoted back to a plain arg later; - * make sure we have enough arg slots left */ - nadjconst++; - prev_was_const = !prev_was_const; - } - else { - argp++->p = NULL; - nargs++; - prev_was_const = FALSE; - } +Perl_op_lvalue_flags() is a non-API lower-level interface to +op_lvalue(). The flags param has these bits: + OP_LVALUE_NO_CROAK: return rather than croaking on error - if (last) - break; - } +*/ + +OP * +Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) +{ + OP *top_op = o; - toparg = argp - 1; + if (!o || (PL_parser && PL_parser->error_count)) + return o; - if (stacked_last) - return; /* we don't support ((A.=B).=C)...) */ + while (1) { + OP *kid; + /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ + int localize = -1; + OP *next_kid = NULL; - /* look for two adjacent consts and don't fold them together: - * $o . "a" . "b" - * should do - * $o->concat("a")->concat("b") - * rather than - * $o->concat("ab") - * (but $o .= "a" . "b" should still fold) - */ + if ((o->op_private & OPpTARGET_MY) + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { - bool seen_nonconst = FALSE; - for (argp = toparg; argp >= args; argp--) { - if (argp->p == NULL) { - seen_nonconst = TRUE; - continue; - } - if (!seen_nonconst) - continue; - if (argp[1].p) { - /* both previous and current arg were constants; - * leave the current OP_CONST as-is */ - argp->p = NULL; - nconst--; - nargs++; - } - } + goto do_next; } - /* ----------------------------------------------------------------- - * Phase 2: - * - * At this point we have determined that the optree *can* be converted - * into a multiconcat. Having gathered all the evidence, we now decide - * whether it *should*. - */ + /* elements of a list might be in void context because the list is + in scalar context or because they are attribute sub calls */ + if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID) + goto do_next; + if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; - /* we need at least one concat action, e.g.: - * - * Y . Z - * X = Y . Z - * X .= Y - * - * otherwise we could be doing something like $x = "foo", which - * if treated as as a concat, would fail to COW. - */ - if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2) - return; - - /* Benchmarking seems to indicate that we gain if: - * * we optimise at least two actions into a single multiconcat - * (e.g concat+concat, sassign+concat); - * * or if we can eliminate at least 1 OP_CONST; - * * or if we can eliminate a padsv via OPpTARGET_MY - */ - - if ( - /* eliminated at least one OP_CONST */ - nconst >= 1 - /* eliminated an OP_SASSIGN */ - || o->op_type == OP_SASSIGN - /* eliminated an OP_PADSV */ - || (!targmyop && is_targable) - ) - /* definitely a net gain to optimise */ - goto optimise; + switch (o->op_type) { + case OP_UNDEF: + if (type == OP_SASSIGN) + goto nomod; + PL_modcount++; + goto do_next; - /* ... if not, what else? */ + case OP_STUB: + if ((o->op_flags & OPf_PARENS)) + break; + goto nomod; - /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1): - * multiconcat is faster (due to not creating a temporary copy of - * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is - * faster. - */ - if ( nconst == 0 - && nargs == 2 - && targmyop - && topop->op_type == OP_CONCAT - ) { - PADOFFSET t = targmyop->op_targ; - OP *k1 = cBINOPx(topop)->op_first; - OP *k2 = cBINOPx(topop)->op_last; - if ( k2->op_type == OP_PADSV - && k2->op_targ == t - && ( k1->op_type != OP_PADSV - || k1->op_targ != t) - ) - goto optimise; - } + 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(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */ + break; + } + else { /* lvalue subroutine call */ + o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (S_potential_mod_type(type)) { + o->op_private |= OPpENTERSUB_INARGS; + break; + } + else { /* Compile-time error message: */ + OP *kid = cUNOPo->op_first; + CV *cv; + GV *gv; + SV *namesv; - /* need at least two concats */ - if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3) - return; + 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_ + "panic: 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; + if (flags & OP_LVALUE_NO_CROAK) + return NULL; - /* ----------------------------------------------------------------- - * Phase 3: - * - * At this point the optree has been verified as ok to be optimised - * into an OP_MULTICONCAT. Now start changing things. - */ + namesv = cv_name(cv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " + "subroutine call of &%" SVf " in %s", + SVfARG(namesv), PL_op_desc[type]), + SvUTF8(namesv)); + goto do_next; + } + } + /* FALLTHROUGH */ + default: + nomod: + if (flags & OP_LVALUE_NO_CROAK) return NULL; + /* grep, foreach, subcalls, refgen */ + if (S_potential_mod_type(type)) + break; + yyerror(Perl_form(aTHX_ "Can't modify %s in %s", + (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) + ? "do block" + : OP_DESC(o)), + type ? PL_op_desc[type] : "local")); + goto do_next; - optimise: + 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; - /* stringify all const args and determine utf8ness */ + 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; + /* we recurse rather than iterate here because we need to + * calculate and use the delta applied to PL_modcount by the + * first child. So in something like + * ($x, ($y) x 3) = split; + * split knows that 4 elements are wanted + */ + 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; - variant = 0; - for (argp = args; argp <= toparg; argp++) { - SV *sv = (SV*)argp->p; - if (!sv) - continue; /* not a const op */ - if (utf8 && !SvUTF8(sv)) - sv_utf8_upgrade_nomg(sv); - argp->p = SvPV_nomg(sv, argp->len); - total_len += argp->len; + case OP_COND_EXPR: + localize = 1; + next_kid = OpSIBLING(cUNOPo->op_first); + break; - /* see if any strings would grow if converted to utf8 */ - if (!utf8) { - variant += variant_under_utf8_count((U8 *) argp->p, - (U8 *) argp->p + argp->len); + case OP_RV2AV: + case OP_RV2HV: + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { + PL_modcount = RETURN_UNLIMITED_NUMBER; + /* Treat \(@foo) like ordinary list, but still mark it as modi- + fiable since some contexts need to know. */ + o->op_flags |= OPf_MOD; + goto do_next; } - } + /* 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; - /* create and populate aux struct */ + case OP_KVHSLICE: + case OP_KVASLICE: + case OP_AKEYS: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + goto nomod; - create_aux: + case OP_AVHVSWITCH: + if (type == OP_LEAVESUBLV + && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) + o->op_private |= OPpMAYBE_LVSUB; + goto nomod; - aux = (UNOP_AUX_item*)PerlMemShared_malloc( - sizeof(UNOP_AUX_item) - * ( - PERL_MULTICONCAT_HEADER_SIZE - + ((nargs + 1) * (variant ? 2 : 1)) - ) - ); - const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1); + case OP_AV2ARYLEN: + PL_hints |= HINT_BLOCK_SCOPE; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + PL_modcount++; + break; - /* Extract all the non-const expressions from the concat tree then - * dispose of the old tree, e.g. convert the tree from this: - * - * o => SASSIGN - * | - * STRINGIFY -- TARGET - * | - * ex-PUSHMARK -- CONCAT - * | - * CONCAT -- EXPR5 - * | - * CONCAT -- EXPR4 - * | - * CONCAT -- EXPR3 - * | - * EXPR1 -- EXPR2 - * - * - * to: - * - * o => MULTICONCAT - * | - * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET - * - * except that if EXPRi is an OP_CONST, it's discarded. - * - * During the conversion process, EXPR ops are stripped from the tree - * and unshifted onto o. Finally, any of o's remaining original - * childen are discarded and o is converted into an OP_MULTICONCAT. - * - * In this middle of this, o may contain both: unshifted args on the - * left, and some remaining original args on the right. lastkidop - * is set to point to the right-most unshifted arg to delineate - * between the two sets. - */ + 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; - if (is_sprintf) { - /* create a copy of the format with the %'s removed, and record - * the sizes of the const string segments in the aux struct */ - char *q, *oldq; - lenp = aux + PERL_MULTICONCAT_IX_LENGTHS; - - p = sprintf_info.start; - q = const_str; - oldq = q; - for (; p < sprintf_info.end; p++) { - if (*p == '%') { - p++; - if (*p != '%') { - (lenp++)->ssize = q - oldq; - oldq = q; - continue; - } - } - *q++ = *p; + case OP_PADAV: + case OP_PADHV: + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (type == OP_REFGEN && o->op_flags & OPf_PARENS) + { + /* Treat \(@foo) like ordinary list, but still mark it as modi- + fiable since some contexts need to know. */ + o->op_flags |= OPf_MOD; + goto do_next; } - lenp->ssize = q - oldq; - assert((STRLEN)(q - const_str) == total_len); + 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; - /* Attach all the args (i.e. the kids of the sprintf) to o (which - * may or may not be topop) The pushmark and const ops need to be - * kept in case they're an op_next entry point. - */ - lastkidop = cLISTOPx(topop)->op_last; - kid = cUNOPx(topop)->op_first; /* pushmark */ - op_null(kid); - op_null(OpSIBLING(kid)); /* const */ - if (o != topop) { - kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */ - op_sibling_splice(o, NULL, 0, kid); /* and attach to o */ - lastkidop->op_next = o; - } - } - else { - p = const_str; - lenp = aux + PERL_MULTICONCAT_IX_LENGTHS; + case OP_PUSHMARK: + localize = 0; + break; - lenp->ssize = -1; + case OP_KEYS: + if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) + 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 && OpHAS_SIBLING(cBINOPo->op_first)) { + /* we recurse rather than iterate here because the child + * needs to be processed with a different 'type' parameter */ - /* Concatenate all const strings into const_str. - * Note that args[] contains the RHS args in reverse order, so - * we scan args[] from top to bottom to get constant strings - * in L-R order - */ - for (argp = toparg; argp >= args; argp--) { - if (!argp->p) - /* not a const op */ - (++lenp)->ssize = -1; - else { - STRLEN l = argp->len; - Copy(argp->p, p, l, char); - p += l; - if (lenp->ssize == -1) - lenp->ssize = l; - else - lenp->ssize += l; - } + /* substr and vec */ + /* If this op is in merely potential (non-fatal) modifiable + context, then apply OP_ENTERSUB context to + the kid op (to avoid croaking). Other- + wise pass this op’s own type so the correct op is mentioned + in error messages. */ + op_lvalue(OpSIBLING(cBINOPo->op_first), + S_potential_mod_type(type) + ? (I32)OP_ENTERSUB + : o->op_type); } + break; - kid = topop; - nextop = o; - lastkidop = NULL; + 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; - for (argp = args; argp <= toparg; argp++) { - /* only keep non-const args, except keep the first-in-next-chain - * arg no matter what it is (but nulled if OP_CONST), because it - * may be the entry point to this subtree from the previous - * op_next. - */ - bool last = (argp == toparg); - OP *prev; + 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) + next_kid = cLISTOPo->op_last; + break; + + case OP_NULL: + localize = 0; + if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ + goto nomod; + else if (!(o->op_flags & OPf_KIDS)) + break; - /* set prev to the sibling *before* the arg to be cut out, - * e.g. when cutting EXPR: + if (o->op_targ != OP_LIST) { + OP *sib = OpSIBLING(cLISTOPo->op_first); + /* OP_TRANS and OP_TRANSR with argument have a weird optree + * that looks like + * + * null + * arg + * trans + * + * compared with things like OP_MATCH which have the argument + * as a child: * - * | - * kid= CONCAT - * | - * prev= CONCAT -- EXPR - * | + * match + * arg + * + * so handle specially to correctly get "Can't modify" croaks etc */ - if (argp == args && kid->op_type != OP_CONCAT) { - /* in e.g. '$x .= f(1)' there's no RHS concat tree - * so the expression to be cut isn't kid->op_last but - * kid itself */ - OP *o1, *o2; - /* find the op before kid */ - o1 = NULL; - o2 = cUNOPx(parentop)->op_first; - while (o2 && o2 != kid) { - o1 = o2; - o2 = OpSIBLING(o2); - } - assert(o2 == kid); - prev = o1; - kid = parentop; - } - else if (kid == o && lastkidop) - prev = last ? lastkidop : OpSIBLING(lastkidop); - else - prev = last ? NULL : cUNOPx(kid)->op_first; - - if (!argp->p || last) { - /* cut RH op */ - OP *aop = op_sibling_splice(kid, prev, 1, NULL); - /* and unshift to front of o */ - op_sibling_splice(o, NULL, 0, aop); - /* record the right-most op added to o: later we will - * free anything to the right of it */ - if (!lastkidop) - lastkidop = aop; - aop->op_next = nextop; - if (last) { - if (argp->p) - /* null the const at start of op_next chain */ - op_null(aop); - } - else if (prev) - nextop = prev->op_next; - } - - /* the last two arguments are both attached to the same concat op */ - if (argp < toparg - 1) - kid = prev; - } - } - - /* Populate the aux struct */ - - aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs; - aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str; - aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len; - aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str; - aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len; - - /* if variant > 0, calculate a variant const string and lengths where - * the utf8 version of the string will take 'variant' more bytes than - * the plain one. */ - - if (variant) { - char *p = const_str; - STRLEN ulen = total_len + variant; - UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; - UNOP_AUX_item *ulens = lens + (nargs + 1); - char *up = (char*)PerlMemShared_malloc(ulen); - SSize_t n; - aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up; - aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen; - - for (n = 0; n < (nargs + 1); n++) { - SSize_t i; - char * orig_up = up; - for (i = (lens++)->ssize; i > 0; i--) { - U8 c = *p++; - append_utf8_from_native_byte(c, (U8**)&up); + if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) + { + /* this should trigger a "Can't modify transliteration" err */ + op_lvalue(sib, type); } - (ulens++)->ssize = (i < 0) ? i : up - orig_up; + next_kid = cBINOPo->op_first; + /* we assume OP_NULLs which aren't ex-list have no more than 2 + * children. If this assumption is wrong, increase the scan + * limit below */ + assert( !OpHAS_SIBLING(next_kid) + || !OpHAS_SIBLING(OpSIBLING(next_kid))); + break; } - } + /* FALLTHROUGH */ + case OP_LIST: + localize = 0; + next_kid = cLISTOPo->op_first; + break; - if (stringop) { - /* if there was a top(ish)-level OP_STRINGIFY, we need to keep - * that op's first child - an ex-PUSHMARK - because the op_next of - * the previous op may point to it (i.e. it's the entry point for - * the o optree) - */ - OP *pmop = - (stringop == o) - ? op_sibling_splice(o, lastkidop, 1, NULL) - : op_sibling_splice(stringop, NULL, 1, NULL); - assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK)); - op_sibling_splice(o, NULL, 0, pmop); - if (!lastkidop) - lastkidop = pmop; - } - - /* Optimise - * target = A.B.C... - * target .= A.B.C... - */ + case OP_COREARGS: + goto do_next; - if (targetop) { - assert(!targmyop); + case OP_AND: + case OP_OR: + if (type == OP_LEAVESUBLV + || !S_vivifies(cLOGOPo->op_first->op_type)) + next_kid = cLOGOPo->op_first; + else if (type == OP_LEAVESUBLV + || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) + next_kid = OpSIBLING(cLOGOPo->op_first); + goto nomod; - if (o->op_type == OP_SASSIGN) { - /* Move the target subtree from being the last of o's children - * to being the last of o's preserved children. - * Note the difference between 'target = ...' and 'target .= ...': - * for the former, target is executed last; for the latter, - * first. - */ - kid = OpSIBLING(lastkidop); - op_sibling_splice(o, kid, 1, NULL); /* cut target op */ - op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */ - lastkidop->op_next = kid->op_next; - lastkidop = targetop; + case OP_SREFGEN: + if (type == OP_NULL) { /* local */ + local_refgen: + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + next_kid = cUNOPo->op_first; + goto do_next; } - else { - /* Move the target subtree from being the first of o's - * original children to being the first of *all* o's children. - */ - if (lastkidop) { - op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */ - op_sibling_splice(o, NULL, 0, targetop); /* and paste*/ - } - else { - /* if the RHS of .= doesn't contain a concat (e.g. - * $x .= "foo"), it gets missed by the "strip ops from the - * tree and add to o" loop earlier */ - assert(topop->op_type != OP_CONCAT); - if (stringop) { - /* in e.g. $x .= "$y", move the $y expression - * from being a child of OP_STRINGIFY to being the - * second child of the OP_CONCAT - */ - assert(cUNOPx(stringop)->op_first == topop); - op_sibling_splice(stringop, NULL, 1, NULL); - op_sibling_splice(o, cUNOPo->op_first, 0, topop); - } - assert(topop == OpSIBLING(cBINOPo->op_first)); - if (toparg->p) - op_null(topop); - lastkidop = topop; + 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_NULL) /* local */ + goto local_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); + goto do_next; - if (is_targable) { - /* optimise - * my $lex = A.B.C... - * $lex = A.B.C... - * $lex .= A.B.C... - * The original padsv op is kept but nulled in case it's the - * entry point for the optree (which it will be for - * '$lex .= ... ' - */ - private_flags |= OPpTARGET_MY; - private_flags |= (targetop->op_private & OPpLVAL_INTRO); - o->op_targ = targetop->op_targ; - targetop->op_targ = 0; - op_null(targetop); - } - else - flags |= OPf_STACKED; - } - else if (targmyop) { - private_flags |= OPpTARGET_MY; - if (o != targmyop) { - o->op_targ = targmyop->op_targ; - targmyop->op_targ = 0; + case OP_SPLIT: + if ((o->op_private & OPpSPLIT_ASSIGN)) { + /* This is actually @array = split. */ + PL_modcount = RETURN_UNLIMITED_NUMBER; + break; } - } + goto nomod; - /* detach the emaciated husk of the sprintf/concat optree and free it */ - for (;;) { - kid = op_sibling_splice(o, lastkidop, 1, NULL); - if (!kid) - break; - op_free(kid); - } + case OP_SCALAR: + op_lvalue(cUNOPo->op_first, OP_ENTERSUB); + goto nomod; - /* and convert o into a multiconcat */ + case OP_ANONCODE: + /* If we were to set OPf_REF on this and it was constructed by XS + * code as a child of an OP_REFGEN then we'd end up generating a + * double-ref when executed. We don't want to do that, so don't + * set flag here. + * See also https://github.com/Perl/perl5/issues/20384 + */ - o->op_flags = (flags|OPf_KIDS|stacked_last - |(o->op_flags & (OPf_WANT|OPf_PARENS))); - o->op_private = private_flags; - o->op_type = OP_MULTICONCAT; - o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT]; - cUNOP_AUXo->op_aux = aux; -} + // Perl always sets OPf_REF as of 5.37.5. + // + if (LIKELY(o->op_flags & OPf_REF)) goto nomod; + // If we got here, then our op came from an XS module that predates + // 5.37.5’s change to the op tree, which we have to handle a bit + // diffrently to preserve backward compatibility. + // + goto do_next; + } -/* do all the final processing on an optree (e.g. running the peephole - * optimiser on it), then attach it to cv (if cv is non-null) - */ + /* [20011101.069 (#7861)] 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 && OP_IS_STAT(o->op_type)) + goto do_next; -static void -S_process_optree(pTHX_ CV *cv, OP *optree, OP* start) -{ - OP **startp; + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; - /* XXX for some reason, evals, require and main optrees are - * never attached to their CV; instead they just hang off - * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start - * and get manually freed when appropriate */ - if (cv) - startp = &CvSTART(cv); - else - startp = PL_in_eval? &PL_eval_start : &PL_main_start; + if (type == OP_AASSIGN || type == OP_SASSIGN) + o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : 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_type != OP_ENTERSUB) + o->op_flags |= OPf_REF; - *startp = start; - optree->op_private |= OPpREFCOUNTED; - OpREFCNT_set(optree, 1); - optimize_optree(optree); - CALL_PEEP(*startp); - finalize_optree(optree); - S_prune_chain_head(startp); + do_next: + while (!next_kid) { + if (o == top_op) + return top_op; /* at top; no parents/siblings to try */ + if (OpHAS_SIBLING(o)) { + next_kid = o->op_sibparent; + if (!OpHAS_SIBLING(next_kid)) { + /* a few node types don't recurse into their second child */ + OP *parent = next_kid->op_sibparent; + I32 ptype = parent->op_type; + if ( (ptype == OP_NULL && parent->op_targ != OP_LIST) + || ( (ptype == OP_AND || ptype == OP_OR) + && (type != OP_LEAVESUBLV + && S_vivifies(next_kid->op_type)) + ) + ) { + /*try parent's next sibling */ + o = parent; + next_kid = NULL; + } + } + } + else + o = o->op_sibparent; /*try parent's next sibling */ - if (cv) { - /* now that optimizer has done its work, adjust pad values */ - pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT - : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); } -} - + o = next_kid; -/* -=for apidoc optimize_optree + } /* while */ -This function applies some optimisations to the optree in top-down order. -It is called before the peephole optimizer, which processes ops in -execution order. Note that finalize_optree() also does a top-down scan, -but is called *after* the peephole optimizer. +} -=cut -*/ -void -Perl_optimize_optree(pTHX_ OP* o) +STATIC bool +S_scalar_mod_type(const OP *o, I32 type) { - PERL_ARGS_ASSERT_OPTIMIZE_OPTREE; + 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_NBIT_AND: + case OP_NBIT_XOR: + case OP_NBIT_OR: + case OP_SBIT_AND: + case OP_SBIT_XOR: + case OP_SBIT_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: + case OP_VEC: + case OP_SUBSTR: + return TRUE; + default: + return FALSE; + } +} - ENTER; - SAVEVPTR(PL_curcop); +STATIC bool +S_is_handle_constructor(const OP *o, I32 numargs) +{ + PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR; - optimize_op(o); + 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; + } +} - LEAVE; +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; } -/* helper for optimize_optree() which optimises one op then recurses - * to optimise any children. +/* Apply reference (autovivification) context to the subtree at o. + * For example in + * push @{expression}, ....; + * o will be the head of 'expression' and type will be OP_RV2AV. + * It marks the op o (or a suitable child) as autovivifying, e.g. by + * setting OPf_MOD. + * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if + * set_op_ref is true. + * + * Also calls scalar(o). */ -STATIC void -S_optimize_op(pTHX_ OP* o) +OP * +Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) { - OP *top_op = o; - - PERL_ARGS_ASSERT_OPTIMIZE_OP; + OP * top_op = o; - while (1) { - OP * next_kid = NULL; + PERL_ARGS_ASSERT_DOREF; - assert(o->op_type != OP_FREED); + if (PL_parser && PL_parser->error_count) + return o; + while (1) { switch (o->op_type) { - case OP_NEXTSTATE: - case OP_DBSTATE: - PL_curcop = ((COP*)o); /* for warnings */ - break; - + 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); + /* disable pushmark */ + op_null(cLISTOPx(cUNOPo->op_first)->op_first); + 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; + } - case OP_CONCAT: - case OP_SASSIGN: - case OP_STRINGIFY: - case OP_SPRINTF: - S_maybe_multiconcat(aTHX_ o); break; - case OP_SUBST: - if (cPMOPo->op_pmreplrootu.op_pmreplroot) { - /* we can't assume that op_pmreplroot->op_sibparent == o - * and that it is thus possible to walk back up the tree - * past op_pmreplroot. So, although we try to avoid - * recursing through op trees, do it here. After all, - * there are unlikely to be many nested s///e's within - * the replacement part of a s///e. - */ - optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); + case OP_COND_EXPR: + o = OpSIBLING(cUNOPo->op_first); + continue; + + case OP_RV2SV: + if (type == OP_DEFINED) + o->op_flags |= OPf_SPECIAL; /* don't create GV */ + /* 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; + } + if (o->op_flags & OPf_KIDS) { + type = o->op_type; + o = cUNOPo->op_first; + continue; } break; - default: + 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 */ + type = o->op_type; + o = cUNOPo->op_first; + continue; + + case OP_PADAV: + case OP_PADHV: + if (set_op_ref) + o->op_flags |= OPf_REF; break; - } - if (o->op_flags & OPf_KIDS) - next_kid = cUNOPo->op_first; + case OP_SCALAR: + case OP_NULL: + if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED) + break; + o = cBINOPo->op_first; + continue; - /* if a kid hasn't been nominated to process, continue with the - * next sibling, or if no siblings left, go back to the parent's - * siblings and so on - */ - while (!next_kid) { - if (o == top_op) - return; /* at top; no parents/siblings to try */ - if (OpHAS_SIBLING(o)) - next_kid = o->op_sibparent; - else - o = o->op_sibparent; /*try parent's next sibling */ - } + case OP_AELEM: + case OP_HELEM: + 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; + } + type = o->op_type; + o = cBINOPo->op_first; + continue;; - /* this label not yet used. Goto here if any code above sets - * next-kid - get_next_op: - */ - o = next_kid; - } -} + case OP_SCOPE: + case OP_LEAVE: + set_op_ref = FALSE; + /* FALLTHROUGH */ + case OP_ENTER: + case OP_LIST: + if (!(o->op_flags & OPf_KIDS)) + break; + o = cLISTOPo->op_last; + continue; + default: + break; + } /* switch */ -/* -=for apidoc finalize_optree + while (1) { + if (o == top_op) + return scalar(top_op); /* at top; no parents/siblings to try */ + if (OpHAS_SIBLING(o)) { + o = o->op_sibparent; + /* Normally skip all siblings and go straight to the parent; + * the only op that requires two children to be processed + * is OP_COND_EXPR */ + if (!OpHAS_SIBLING(o) + && o->op_sibparent->op_type == OP_COND_EXPR) + break; + continue; + } + o = o->op_sibparent; /*try parent's next sibling */ + } + } /* while */ +} -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 Cxxx functions and makes -the tree thread-safe. -=cut -*/ -void -Perl_finalize_optree(pTHX_ OP* o) +STATIC OP * +S_dup_attrlist(pTHX_ OP *o) { - PERL_ARGS_ASSERT_FINALIZE_OPTREE; - - ENTER; - SAVEVPTR(PL_curcop); + OP *rop; - finalize_op(o); + PERL_ARGS_ASSERT_DUP_ATTRLIST; - LEAVE; + /* 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; } -#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) +STATIC void +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - 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 - -/* -=for apidoc traverse_op_tree - -Return the next op in a depth-first traversal of the op tree, -returning NULL when the traversal is complete. - -The initial call must supply the root of the tree as both top and o. - -For now it's static, but it may be exposed to the API in the future. - -=cut -*/ - -STATIC OP* -S_traverse_op_tree(pTHX_ OP *top, OP *o) { - OP *sib; + PERL_ARGS_ASSERT_APPLY_ATTRS; + { + SV * const stashsv = newSVhek(HvNAME_HEK(stash)); - PERL_ARGS_ASSERT_TRAVERSE_OP_TREE; + /* fake up C */ - if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) { - return cUNOPo->op_first; - } - else if ((sib = OpSIBLING(o))) { - return sib; - } - else { - OP *parent = o->op_sibparent; - assert(!(o->op_moresib)); - while (parent && parent != top) { - OP *sib = OpSIBLING(parent); - if (sib) - return sib; - parent = parent->op_sibparent; - } +#define ATTRSMODULE "attributes" +#define ATTRSMODULE_PM "attributes.pm" - return NULL; + 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_finalize_op(pTHX_ OP* o) +S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { - OP * const top = o; - PERL_ARGS_ASSERT_FINALIZE_OP; - - do { - assert(o->op_type != OP_FREED); + OP *pack, *imop, *arg; + SV *meth, *stashsv, **svp; - 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; + PERL_ARGS_ASSERT_APPLY_ATTRS_MY; - 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; + if (!attrs) + return; - case OP_CONST: - if (cSVOPo->op_private & OPpCONST_STRICT) - no_bareword_allowed(o); -#ifdef USE_ITHREADS - /* FALLTHROUGH */ - case OP_HINTSEVAL: - op_relocate_sv(&cSVOPo->op_sv, &o->op_targ); -#endif - break; + assert(target->op_type == OP_PADSV || + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); -#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 + /* Ensure that attributes.pm is loaded. */ + /* Don't force the C if we don't need it. */ + svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); + if (svp && *svp != &PL_sv_undef) + NOOP; /* already in %INC */ + else + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs(ATTRSMODULE), NULL); - case OP_HELEM: { - UNOP *rop; - SVOP *key_op; - OP *kid; + /* Need package name for method call. */ + pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); - if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST) - break; + /* Build up the real arg-list. */ + stashsv = newSVhek(HvNAME_HEK(stash)); - rop = (UNOP*)((BINOP*)o)->op_first; + arg = newPADxVOP(OP_PADSV, 0, 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))); - goto check_keys; + /* Fake up a method call to import */ + meth = newSVpvs_share("import"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); - case OP_HSLICE: - S_scalar_slice_warning(aTHX_ o); - /* FALLTHROUGH */ + /* Combine the ops. */ + *imopsp = op_append_elem(OP_LIST, *imopsp, imop); +} - 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; - } +/* +=notfor apidoc apply_attrs_string - key_op = (SVOP*)(kid->op_type == OP_CONST - ? kid - : OpSIBLING(kLISTOP->op_first)); +Attempts to apply a list of attributes specified by the C and +C arguments to the subroutine identified by the C argument which +is expected to be associated with the package identified by the C +argument (see L). It gets this wrong, though, in that it +does not correctly identify the boundaries of the individual attribute +specifications within C. 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 keyword from F.) Patches to fix it +to respect attribute syntax properly would be welcome. - rop = (UNOP*)((LISTOP*)o)->op_last; +=cut +*/ - 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, 1); - break; - } - case OP_NULL: - if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE) - break; - /* FALLTHROUGH */ - case OP_ASLICE: - S_scalar_slice_warning(aTHX_ o); - break; +void +Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, + const char *attrstr, STRLEN len) +{ + OP *attrs = NULL; - case OP_SUBST: { - if (cPMOPo->op_pmreplrootu.op_pmreplroot) - finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot); - break; - } - default: - break; - } + PERL_ARGS_ASSERT_APPLY_ATTRS_STRING; -#ifdef DEBUGGING - if (o->op_flags & OPf_KIDS) { - OP *kid; + if (!len) { + len = strlen(attrstr); + } - /* 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 - || type == OP_CUSTOM - || type == OP_NULL /* new_logop does this */ - ); - - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { - if (!OpHAS_SIBLING(kid)) { - if (has_last) - assert(kid == cLISTOPo->op_last); - assert(kid->op_sibparent == o); - } - } + 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))); } -#endif - } while (( o = traverse_op_tree(top, o)) != NULL); -} - -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); } + + 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 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; -} - - -/* apply lvalue reference (aliasing) context to the optree o. - * E.g. in - * \($x,$y) = (...) - * o would be the list ($x,$y) and type would be OP_AASSIGN. - * It may descend and apply this to children too, for example in - * \( $cond ? $x, $y) = (...) - */ - -static void -S_lvref(pTHX_ OP *o, I32 type) -{ - dVAR; - OP *kid; - OP * top_op = o; - - while (1) { - switch (o->op_type) { - case OP_COND_EXPR: - o = OpSIBLING(cUNOPo->op_first); - continue; - - case OP_PUSHMARK: - goto do_next; - - 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")); - goto do_next; - } - slurpy: - OpTYPE_set(o, OP_LVAVREF); - o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE; - o->op_flags |= OPf_MOD|OPf_REF; - goto do_next; - } - 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")); - goto do_next; - } - 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; - goto do_next; - - case OP_NULL: - if (o->op_flags & OPf_SPECIAL) /* do BLOCK */ - goto badref; - else if (!(o->op_flags & OPf_KIDS)) - goto do_next; - - /* the code formerly only recursed into the first child of - * a non ex-list OP_NULL. if we ever encounter such a null op with - * more than one child, need to decide whether its ok to process - * *all* its kids or not */ - assert(o->op_targ == OP_LIST - || !(OpHAS_SIBLING(cBINOPo->op_first))); - /* FALLTHROUGH */ - case OP_LIST: - o = cLISTOPo->op_first; - continue; - - case OP_STUB: - if (o->op_flags & OPf_PARENS) - goto do_next; - /* 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])); - goto do_next; - } - - 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; - - do_next: - while (1) { - if (o == top_op) - return; /* at top; no parents/siblings to try */ - if (OpHAS_SIBLING(o)) { - o = o->op_sibparent; - break; - } - o = o->op_sibparent; /*try parent's next sibling */ - } - } /* while */ -} - - -PERL_STATIC_INLINE bool -S_potential_mod_type(I32 type) -{ - /* Types that only potentially result in modification. */ - return type == OP_GREPSTART || type == OP_ENTERSUB - || type == OP_REFGEN || type == OP_LEAVESUBLV; -} - - -/* -=for apidoc op_lvalue - -Propagate lvalue ("modifiable") context to an op and its children. -C represents the context type, roughly based on the type of op that -would do the modifying, although C is represented by C, -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 C and a C argument of C. - -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 - -Perl_op_lvalue_flags() is a non-API lower-level interface to -op_lvalue(). The flags param has these bits: - OP_LVALUE_NO_CROAK: return rather than croaking on error - -*/ - -OP * -Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) -{ - dVAR; - OP *top_op = o; - - if (!o || (PL_parser && PL_parser->error_count)) - return o; - - while (1) { - OP *kid; - /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */ - int localize = -1; - OP *next_kid = NULL; - - if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ - { - goto do_next; - } - - /* elements of a list might be in void context because the list is - in scalar context or because they are attribute sub calls */ - if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID) - goto do_next; - - if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; - - switch (o->op_type) { - case OP_UNDEF: - PL_modcount++; - goto do_next; - - 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 (S_potential_mod_type(type)) { - o->op_private |= OPpENTERSUB_INARGS; - break; - } - else { /* Compile-time error message: */ - OP *kid = cUNOPo->op_first; - CV *cv; - GV *gv; - SV *namesv; - - 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; - if (flags & OP_LVALUE_NO_CROAK) - return NULL; - - namesv = cv_name(cv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " - "subroutine call of &%" SVf " in %s", - SVfARG(namesv), PL_op_desc[type]), - SvUTF8(namesv)); - goto do_next; - } - } - /* FALLTHROUGH */ - default: - nomod: - if (flags & OP_LVALUE_NO_CROAK) return NULL; - /* grep, foreach, subcalls, refgen */ - if (S_potential_mod_type(type)) - break; - yyerror(Perl_form(aTHX_ "Can't modify %s in %s", - (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) - ? "do block" - : OP_DESC(o)), - type ? PL_op_desc[type] : "local")); - goto do_next; - - 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; - /* we recurse rather than iterate here because we need to - * calculate and use the delta applied to PL_modcount by the - * first child. So in something like - * ($x, ($y) x 3) = split; - * split knows that 4 elements are wanted - */ - 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; - next_kid = OpSIBLING(cUNOPo->op_first); - break; - - case OP_RV2AV: - case OP_RV2HV: - if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { - PL_modcount = RETURN_UNLIMITED_NUMBER; - /* Treat \(@foo) like ordinary list, but still mark it as modi- - fiable since some contexts need to know. */ - o->op_flags |= OPf_MOD; - goto do_next; - } - /* 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: - case OP_AKEYS: - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; - goto nomod; - - case OP_AVHVSWITCH: - if (type == OP_LEAVESUBLV - && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS) - 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) - { - /* Treat \(@foo) like ordinary list, but still mark it as modi- - fiable since some contexts need to know. */ - o->op_flags |= OPf_MOD; - goto do_next; - } - 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: - if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) - 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 && OpHAS_SIBLING(cBINOPo->op_first)) { - /* we recurse rather than iterate here because the child - * needs to be processed with a different 'type' parameter */ - - /* substr and vec */ - /* If this op is in merely potential (non-fatal) modifiable - context, then apply OP_ENTERSUB context to - the kid op (to avoid croaking). Other- - wise pass this op’s own type so the correct op is mentioned - in error messages. */ - op_lvalue(OpSIBLING(cBINOPo->op_first), - S_potential_mod_type(type) - ? (I32)OP_ENTERSUB - : o->op_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) - next_kid = cLISTOPo->op_last; - 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 *sib = OpSIBLING(cLISTOPo->op_first); - /* OP_TRANS and OP_TRANSR with argument have a weird optree - * that looks like - * - * null - * arg - * trans - * - * compared with things like OP_MATCH which have the argument - * as a child: - * - * match - * arg - * - * so handle specially to correctly get "Can't modify" croaks etc - */ - - if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) - { - /* this should trigger a "Can't modify transliteration" err */ - op_lvalue(sib, type); - } - next_kid = cBINOPo->op_first; - /* we assume OP_NULLs which aren't ex-list have no more than 2 - * children. If this assumption is wrong, increase the scan - * limit below */ - assert( !OpHAS_SIBLING(next_kid) - || !OpHAS_SIBLING(OpSIBLING(next_kid))); - break; - } - /* FALLTHROUGH */ - case OP_LIST: - localize = 0; - next_kid = cLISTOPo->op_first; - break; - - case OP_COREARGS: - goto do_next; - - case OP_AND: - case OP_OR: - if (type == OP_LEAVESUBLV - || !S_vivifies(cLOGOPo->op_first->op_type)) - next_kid = cLOGOPo->op_first; - else if (type == OP_LEAVESUBLV - || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type)) - next_kid = OpSIBLING(cLOGOPo->op_first); - goto nomod; - - case OP_SREFGEN: - if (type == OP_NULL) { /* local */ - local_refgen: - if (!FEATURE_MYREF_IS_ENABLED) - Perl_croak(aTHX_ "The experimental declared_refs " - "feature is not enabled"); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), - "Declaring references is experimental"); - next_kid = cUNOPo->op_first; - goto do_next; - } - 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_NULL) /* local */ - goto local_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); - goto do_next; - - case OP_SPLIT: - if ((o->op_private & OPpSPLIT_ASSIGN)) { - /* 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 (#7861)] 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 && OP_IS_STAT(o->op_type)) - goto do_next; - - if (type != OP_LEAVESUBLV) - o->op_flags |= OPf_MOD; - - if (type == OP_AASSIGN || type == OP_SASSIGN) - o->op_flags |= OPf_SPECIAL - |(o->op_type == OP_ENTERSUB ? 0 : 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_type != OP_ENTERSUB) - o->op_flags |= OPf_REF; - - do_next: - while (!next_kid) { - if (o == top_op) - return top_op; /* at top; no parents/siblings to try */ - if (OpHAS_SIBLING(o)) { - next_kid = o->op_sibparent; - if (!OpHAS_SIBLING(next_kid)) { - /* a few node types don't recurse into their second child */ - OP *parent = next_kid->op_sibparent; - I32 ptype = parent->op_type; - if ( (ptype == OP_NULL && parent->op_targ != OP_LIST) - || ( (ptype == OP_AND || ptype == OP_OR) - && (type != OP_LEAVESUBLV - && S_vivifies(next_kid->op_type)) - ) - ) { - /*try parent's next sibling */ - o = parent; - next_kid = NULL; - } - } - } - else - o = o->op_sibparent; /*try parent's next sibling */ - - } - o = next_kid; - - } /* while */ - -} - - -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_NBIT_AND: - case OP_NBIT_XOR: - case OP_NBIT_OR: - case OP_SBIT_AND: - case OP_SBIT_XOR: - case OP_SBIT_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: - case OP_VEC: - case OP_SUBSTR: - 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; -} - - -/* Apply reference (autovivification) context to the subtree at o. - * For example in - * push @{expression}, ....; - * o will be the head of 'expression' and type will be OP_RV2AV. - * It marks the op o (or a suitable child) as autovivifying, e.g. by - * setting OPf_MOD. - * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if - * set_op_ref is true. - * - * Also calls scalar(o). - */ - -OP * -Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) -{ - dVAR; - OP * top_op = o; - - PERL_ARGS_ASSERT_DOREF; - - if (PL_parser && PL_parser->error_count) - return o; - - while (1) { - 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); - /* disable pushmark */ - op_null(((LISTOP*)cUNOPo->op_first)->op_first); - 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: - o = OpSIBLING(cUNOPo->op_first); - continue; - - case OP_RV2SV: - if (type == OP_DEFINED) - o->op_flags |= OPf_SPECIAL; /* don't create GV */ - /* 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; - } - if (o->op_flags & OPf_KIDS) { - type = o->op_type; - o = cUNOPo->op_first; - continue; - } - 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 */ - type = o->op_type; - o = cUNOPo->op_first; - continue; - - 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; - o = cBINOPo->op_first; - continue; - - case OP_AELEM: - case OP_HELEM: - 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; - } - type = o->op_type; - o = cBINOPo->op_first; - continue;; - - case OP_SCOPE: - case OP_LEAVE: - set_op_ref = FALSE; - /* FALLTHROUGH */ - case OP_ENTER: - case OP_LIST: - if (!(o->op_flags & OPf_KIDS)) - break; - o = cLISTOPo->op_last; - continue; - - default: - break; - } /* switch */ - - while (1) { - if (o == top_op) - return scalar(top_op); /* at top; no parents/siblings to try */ - if (OpHAS_SIBLING(o)) { - o = o->op_sibparent; - /* Normally skip all siblings and go straight to the parent; - * the only op that requires two children to be processed - * is OP_COND_EXPR */ - if (!OpHAS_SIBLING(o) - && o->op_sibparent->op_type == OP_COND_EXPR) - break; - continue; - } - o = o->op_sibparent; /*try parent's next sibling */ - } - } /* while */ -} - - -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) -{ - PERL_ARGS_ASSERT_APPLY_ATTRS; - { - SV * const stashsv = newSVhek(HvNAME_HEK(stash)); - - /* fake up C */ - -#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 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 = newSVhek(HvNAME_HEK(stash)); - - 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 and -C arguments to the subroutine identified by the C argument which -is expected to be associated with the package identified by the C -argument (see L). It gets this wrong, though, in that it -does not correctly identify the boundaries of the individual attribute -specifications within C. 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 keyword from F.) 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, - bool curstash) +STATIC void +S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name, + bool curstash) { OP *new_proto = NULL; STRLEN pvlen; @@ -5154,10 +3998,8 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name, 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); + op_free(new_proto); new_proto = o; /* excise new_proto from the list */ op_sibling_splice(*attrs, lasto, 1, NULL); @@ -5207,8 +4049,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name, UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), SVfARG(svname)); } - if (*proto) - op_free(*proto); + op_free(*proto); *proto = new_proto; } } @@ -5238,72 +4079,72 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) PERL_ARGS_ASSERT_MY_KID; if (!o || (PL_parser && PL_parser->error_count)) - return o; + return o; type = o->op_type; if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) - my_kid(kid, attrs, imopsp); - return o; + my_kid(kid, attrs, imopsp); + return o; } else if (type == OP_UNDEF || type == OP_STUB) { - return o; + return o; } else if (type == OP_RV2SV || /* "our" declaration */ - type == OP_RV2AV || - type == OP_RV2HV) { - 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 ? GvSVn(gv) : - type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) : - type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)), - attrs); - } - o->op_private |= OPpOUR_INTRO; - return o; + type == OP_RV2AV || + type == OP_RV2HV) { + 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 ? GvSVn(gv) : + type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) : + type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)), + attrs); + } + o->op_private |= OPpOUR_INTRO; + return o; } else if (type == OP_REFGEN || type == OP_SREFGEN) { - if (!FEATURE_MYREF_IS_ENABLED) - Perl_croak(aTHX_ "The experimental declared_refs " - "feature is not enabled"); - Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), - "Declaring references is experimental"); - /* Kid is a nulled OP_LIST, handled above. */ - my_kid(cUNOPo->op_first, attrs, imopsp); - return o; + if (!FEATURE_MYREF_IS_ENABLED) + Perl_croak(aTHX_ "The experimental declared_refs " + "feature is not enabled"); + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__DECLARED_REFS), + "Declaring references is experimental"); + /* Kid is a nulled OP_LIST, handled above. */ + my_kid(cUNOPo->op_first, attrs, imopsp); + return o; } else if (type != OP_PADSV && - type != OP_PADAV && - type != OP_PADHV && - type != OP_PUSHMARK) + type != OP_PADAV && + type != OP_PADHV && + type != OP_PUSHMARK) { - S_cant_declare(aTHX_ o); - return o; + S_cant_declare(aTHX_ o); + return o; } else if (attrs && type != OP_PUSHMARK) { - HV *stash; + HV *stash; assert(PL_parser); - PL_parser->in_my = FALSE; - PL_parser->in_my_stash = NULL; + PL_parser->in_my = FALSE; + PL_parser->in_my_stash = NULL; - /* check for C when deciding package */ - stash = PAD_COMPNAME_TYPE(o->op_targ); - if (!stash) - stash = PL_curstash; - apply_attrs_my(stash, o, attrs, imopsp); + /* check for C 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; + o->op_private |= OPpPAD_STATE; return o; } @@ -5319,35 +4160,35 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) C< our(%x); > executing in list mode rather than void mode */ #if 0 if (o->op_flags & OPf_PARENS) - list(o); + list(o); else - maybe_scalar = 1; + maybe_scalar = 1; #else maybe_scalar = 1; #endif if (attrs) - SAVEFREEOP(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; + 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 = cLISTOPx(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); - } + op_free(pushmark); + } + o = op_append_list(OP_LIST, o, rops); + } } PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -5359,7 +4200,7 @@ Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; if (o) - o->op_flags |= OPf_PARENS; + o->op_flags |= OPf_PARENS; return o; } @@ -5374,53 +4215,52 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) PERL_ARGS_ASSERT_BIND_MATCH; if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV - || ltype == OP_PADHV) && ckWARN(WARN_MISC)) + || 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]; + = 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); + SV * const name = op_varname(left); if (name) - Perl_warner(aTHX_ packWARN(WARN_MISC), + 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), + 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) + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) { - no_bareword_allowed(right); + 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"); + 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"); + /* 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); + 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; + 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 @@ -5435,31 +4275,189 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 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; + ! (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)); + 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 NULL; return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o)); } +/* Warn about possible precedence issues if op is a control flow operator that + does not terminate normally (return, exit, next, etc). +*/ +static bool +S_is_control_transfer(pTHX_ OP *op) +{ + assert(op != NULL); + + /* [perl #59802]: Warn about things like "return $a or $b", which + is parsed as "(return $a) or $b" rather than "return ($a or + $b)". + */ + switch (op->op_type) { + case OP_DUMP: + case OP_NEXT: + case OP_LAST: + case OP_REDO: + case OP_EXIT: + case OP_RETURN: + 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 (!op->op_folded && !(op->op_flags & OPf_PARENS)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Possible precedence issue with control flow operator (%s)", OP_DESC(op)); + + return true; + } + + return false; +} + +OP * +Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right) +{ + BINOP *bop; + OP *op; + + if (!left) + left = newOP(OP_NULL, 0); + else + (void)S_is_control_transfer(aTHX_ left); + if (!right) + right = newOP(OP_NULL, 0); + scalar(left); + scalar(right); + NewOp(0, bop, 1, BINOP); + op = (OP*)bop; + ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP); + OpTYPE_set(op, type); + cBINOPx(op)->op_flags = OPf_KIDS; + cBINOPx(op)->op_private = 2; + cBINOPx(op)->op_first = left; + cBINOPx(op)->op_last = right; + OpMORESIB_set(left, right); + OpLASTSIB_set(right, op); + return op; +} + +OP * +Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right) +{ + BINOP *bop; + OP *op; + + PERL_ARGS_ASSERT_CMPCHAIN_EXTEND; + if (!right) + right = newOP(OP_NULL, 0); + scalar(right); + NewOp(0, bop, 1, BINOP); + op = (OP*)bop; + ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP); + OpTYPE_set(op, type); + if (ch->op_type != OP_NULL) { + UNOP *lch; + OP *nch, *cleft, *cright; + NewOp(0, lch, 1, UNOP); + nch = (OP*)lch; + OpTYPE_set(nch, OP_NULL); + nch->op_flags = OPf_KIDS; + cleft = cBINOPx(ch)->op_first; + cright = cBINOPx(ch)->op_last; + cBINOPx(ch)->op_first = NULL; + cBINOPx(ch)->op_last = NULL; + cBINOPx(ch)->op_private = 0; + cBINOPx(ch)->op_flags = 0; + cUNOPx(nch)->op_first = cright; + OpMORESIB_set(cright, ch); + OpMORESIB_set(ch, cleft); + OpLASTSIB_set(cleft, nch); + ch = nch; + } + OpMORESIB_set(right, op); + OpMORESIB_set(op, cUNOPx(ch)->op_first); + cUNOPx(ch)->op_first = right; + return ch; +} + +OP * +Perl_cmpchain_finish(pTHX_ OP *ch) +{ + + PERL_ARGS_ASSERT_CMPCHAIN_FINISH; + if (ch->op_type != OP_NULL) { + OPCODE cmpoptype = ch->op_type; + ch = CHECKOP(cmpoptype, ch); + if(!ch->op_next && ch->op_type == cmpoptype) + ch = fold_constants(op_integerize(op_std_init(ch))); + return ch; + } else { + OP *condop = NULL; + OP *rightarg = cUNOPx(ch)->op_first; + cUNOPx(ch)->op_first = OpSIBLING(rightarg); + OpLASTSIB_set(rightarg, NULL); + while (1) { + OP *cmpop = cUNOPx(ch)->op_first; + OP *leftarg = OpSIBLING(cmpop); + OPCODE cmpoptype = cmpop->op_type; + OP *nextrightarg; + bool is_last; + is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg)); + OpLASTSIB_set(cmpop, NULL); + OpLASTSIB_set(leftarg, NULL); + if (is_last) { + ch->op_flags = 0; + op_free(ch); + nextrightarg = NULL; + } else { + nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg); + leftarg = newOP(OP_NULL, 0); + } + cBINOPx(cmpop)->op_first = leftarg; + cBINOPx(cmpop)->op_last = rightarg; + OpMORESIB_set(leftarg, rightarg); + OpLASTSIB_set(rightarg, cmpop); + cmpop->op_flags = OPf_KIDS; + cmpop->op_private = 2; + cmpop = CHECKOP(cmpoptype, cmpop); + if(!cmpop->op_next && cmpop->op_type == cmpoptype) + cmpop = op_integerize(op_std_init(cmpop)); + condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : + cmpop; + if (!nextrightarg) + return condop; + rightarg = nextrightarg; + } + } +} + /* =for apidoc op_scope @@ -5477,29 +4475,28 @@ structure. 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, + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o); OpTYPE_set(o, OP_LEAVE); - } - else if (o->op_type == OP_LINESEQ) { - OP *kid; + } + 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); + kid = cLISTOPo->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; } @@ -5508,10 +4505,10 @@ 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); + 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; } @@ -5562,81 +4559,81 @@ OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; - OP* retval = scalarseq(seq); + OP* retval = voidnonfinal(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); + 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 */ + 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); + /* 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); @@ -5645,7 +4642,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) } /* -=head1 Compile-time scope hooks +=for apidoc_section $scope =for apidoc blockhook_register @@ -5671,35 +4668,35 @@ 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 = CX_CUR(); - 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); + 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 = CX_CUR(); + 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_LIST) + list(PL_eval_root); + else + scalar(PL_eval_root); start = op_linklist(PL_eval_root); - PL_eval_root->op_next = 0; - i = PL_savestack_ix; - SAVEFREEOP(o); - ENTER; + PL_eval_root->op_next = 0; + i = PL_savestack_ix; + SAVEFREEOP(o); + ENTER; S_process_optree(aTHX_ NULL, PL_eval_root, start); - LEAVE; - PL_savestack_ix = i; + LEAVE; + PL_savestack_ix = i; } else { - if (o->op_type == OP_STUB) { + 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 @@ -5726,33 +4723,35 @@ Perl_newPROG(pTHX_ OP *o) 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_comppad_name = 0; + PL_compcv = 0; + S_op_destroy(aTHX_ o); + return; + } + PL_main_root = op_scope(sawparens(scalarvoid(o))); + PL_curcop = &PL_compiling; start = LINKLIST(PL_main_root); - PL_main_root->op_next = 0; + PL_main_root->op_next = 0; S_process_optree(aTHX_ NULL, PL_main_root, start); if (!PL_parser->error_count) /* on error, leave CV slabbed so that ops left lying around * will eb cleaned up. Else unslab */ 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); - } - } + PL_compcv = 0; + + /* Register with debugger */ + if (PERLDB_INTER) { + CV * const cv = get_cvs("DB::postponed", 0); + if (cv) { + PUSHMARK(PL_stack_sp); + SV *comp = MUTABLE_SV(CopFILEGV(&PL_compiling)); +#ifdef PERL_RC_STACK + assert(rpp_stack_is_rc()); +#endif + rpp_xpush_1(comp); + call_sv(MUTABLE_SV(cv), G_DISCARD); + } + } } } @@ -5765,53 +4764,53 @@ Perl_localize(pTHX_ OP *o, I32 lex) /* [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); + list(o); #else - NOOP; + 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 && (memCHRs(", \t\n", *s))) - s++; - - while (1) { - if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*')) - && *++s - && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { - s++; - sigil = TRUE; - while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) - s++; - while (*s && (memCHRs(", \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 ( 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 && (memCHRs(", \t\n", *s))) + s++; + + while (1) { + if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*')) + && *++s + && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { + s++; + sigil = TRUE; + while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) + s++; + while (*s && (memCHRs(", \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); + o = my(o); else - o = op_lvalue(o, OP_NULL); /* a bit kludgey */ + o = op_lvalue(o, OP_NULL); /* a bit kludgey */ PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; return o; @@ -5823,9 +4822,17 @@ 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)); + if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) { + 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)); + } + else { + /* If the user disables this, then a warning might not be enough to alert + them to a possible change of behaviour here, so throw an exception. + */ + yyerror("Multidimensional hash lookup is disabled"); + } } return o; } @@ -5838,9 +4845,9 @@ S_op_std_init(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_STD_INIT; if (PL_opargs[type] & OA_RETSCALAR) - scalar(o); + scalar(o); if (PL_opargs[type] & OA_TARGET && !o->op_targ) - o->op_targ = pad_alloc(type, SVs_PADTMP); + o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } @@ -5855,21 +4862,21 @@ S_op_integerize(pTHX_ OP *o) /* integerize op. */ if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)) { - dVAR; - o->op_ppaddr = PL_ppaddr[++(o->op_type)]; + 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; + /* XXX might want a ck_negate() for this */ + cUNOPo->op_first->op_private &= ~OPpCONST_STRICT; return o; } /* This function exists solely to provide a scope to limit - setjmp/longjmp() messing with auto variables. + setjmp/longjmp() messing with auto variables. It cannot be inlined because + it uses setjmp */ -PERL_STATIC_INLINE int +STATIC int S_fold_constants_eval(pTHX) { int ret = 0; dJMPENV; @@ -5877,7 +4884,7 @@ S_fold_constants_eval(pTHX) { JMPENV_PUSH(ret); if (ret == 0) { - CALLRUNOPS(aTHX); + CALLRUNOPS(aTHX); } JMPENV_POP; @@ -5888,7 +4895,6 @@ S_fold_constants_eval(pTHX) { static OP * S_fold_constants(pTHX_ OP *const o) { - dVAR; OP *curop; OP *newop; I32 type = o->op_type; @@ -5905,7 +4911,7 @@ S_fold_constants(pTHX_ OP *const o) PERL_ARGS_ASSERT_FOLD_CONSTANTS; if (!(PL_opargs[type] & OA_FOLDCONST)) - goto nope; + goto nope; switch (type) { case OP_UCFIRST: @@ -5914,8 +4920,8 @@ S_fold_constants(pTHX_ OP *const o) case OP_LC: case OP_FC: #ifdef USE_LOCALE_CTYPE - if (IN_LC_COMPILETIME(LC_CTYPE)) - goto nope; + if (IN_LC_COMPILETIME(LC_CTYPE)) + goto nope; #endif break; case OP_SLT: @@ -5924,44 +4930,44 @@ S_fold_constants(pTHX_ OP *const o) case OP_SGE: case OP_SCMP: #ifdef USE_LOCALE_COLLATE - if (IN_LC_COMPILETIME(LC_COLLATE)) - goto nope; + if (IN_LC_COMPILETIME(LC_COLLATE)) + goto nope; #endif break; case OP_SPRINTF: - /* XXX what about the numeric ops? */ + /* XXX what about the numeric ops? */ #ifdef USE_LOCALE_NUMERIC - if (IN_LC_COMPILETIME(LC_NUMERIC)) - goto nope; + if (IN_LC_COMPILETIME(LC_NUMERIC)) + goto nope; #endif - break; + 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; + 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; + 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 (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 */ + goto nope; /* Don't try to run w/ errors */ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { switch (curop->op_type) { @@ -5981,8 +4987,8 @@ S_fold_constants(pTHX_ OP *const o) default: /* No other op types are considered foldable */ - goto nope; - } + goto nope; + } } curop = LINKLIST(o); @@ -5991,7 +4997,7 @@ S_fold_constants(pTHX_ OP *const o) PL_op = curop; old_cxix = cxstack_ix; - create_eval_scope(NULL, G_FAKINGEVAL); + create_eval_scope(NULL, PL_stack_sp, G_FAKINGEVAL); /* Verify that we don't need to save it: */ assert(PL_curcop == &PL_compiling); @@ -6005,35 +5011,39 @@ S_fold_constants(pTHX_ OP *const o) /* Effective $^W=1. */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; ret = S_fold_constants_eval(aTHX); switch (ret) { case 0: - 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; + sv = *PL_stack_sp; + if (rpp_stack_is_rc()) + SvREFCNT_dec(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; + /* Something tried to die. Abandon constant folding. */ + /* Pretend the error never happened. */ + CLEAR_ERRSV(); + o->op_next = old_next; + break; default: - /* 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); + /* 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); } PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; @@ -6048,7 +5058,7 @@ S_fold_constants(pTHX_ OP *const o) delete_eval_scope(); } if (ret) - goto nope; + goto nope; /* OP_STRINGIFY and constant folding are used to implement qq. Here the constant folding is an implementation detail that we @@ -6058,10 +5068,10 @@ S_fold_constants(pTHX_ OP *const o) op_free(o); assert(sv); if (is_stringify) - SvPADTMP_off(sv); + SvPADTMP_off(sv); else if (!SvIMMORTAL(sv)) { - SvPADTMP_on(sv); - SvREADONLY_on(sv); + SvPADTMP_on(sv); + SvREADONLY_on(sv); } newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); if (!is_stringify) newop->op_folded = 1; @@ -6078,7 +5088,6 @@ S_fold_constants(pTHX_ OP *const o) static void S_gen_constant_list(pTHX_ OP *o) { - dVAR; OP *curop, *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; @@ -6094,22 +5103,22 @@ S_gen_constant_list(pTHX_ OP *o) list(o); if (PL_parser && PL_parser->error_count) - return; /* Don't attempt to run with errors */ + return; /* Don't attempt to run with errors */ curop = LINKLIST(o); old_next = o->op_next; o->op_next = 0; op_was_null = o->op_type == OP_NULL; if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */ - o->op_type = OP_CUSTOM; + o->op_type = OP_CUSTOM; CALL_PEEP(curop); if (op_was_null) - o->op_type = OP_NULL; - S_prune_chain_head(&curop); + o->op_type = OP_NULL; + op_prune_chain_head(&curop); PL_op = curop; old_cxix = cxstack_ix; - create_eval_scope(NULL, G_FAKINGEVAL); + create_eval_scope(NULL, PL_stack_sp, G_FAKINGEVAL); old_curcop = PL_curcop; StructCopy(old_curcop, ¬_compiling, COP); @@ -6123,30 +5132,30 @@ S_gen_constant_list(pTHX_ OP *o) /* Effective $^W=1. */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) - PL_dowarn |= G_WARN_ON; + PL_dowarn |= G_WARN_ON; switch (ret) { case 0: #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */ #endif - Perl_pp_pushmark(aTHX); - CALLRUNOPS(aTHX); - PL_op = curop; - assert (!(curop->op_flags & OPf_SPECIAL)); - assert(curop->op_type == OP_RANGE); - Perl_pp_anonlist(aTHX); - break; + Perl_pp_pushmark(aTHX); + CALLRUNOPS(aTHX); + PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); + Perl_pp_anonlist(aTHX); + break; case 3: - CLEAR_ERRSV(); - o->op_next = old_next; - break; + CLEAR_ERRSV(); + o->op_next = old_next; + break; default: - JMPENV_POP; - PL_warnhook = oldwarnhook; - PL_diehook = olddiehook; - Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", - ret); + JMPENV_POP; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", + ret); } JMPENV_POP; @@ -6161,33 +5170,223 @@ S_gen_constant_list(pTHX_ OP *o) delete_eval_scope(); } if (ret) - return; + return; 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--); + av = (AV *)*PL_stack_sp; + + /* replace subtree with an OP_CONST */ + curop = cUNOPo->op_first; + op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av)); + rpp_pop_1_norc(); + 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); + list(o); + return; +} + +/* +=for apidoc_section $optree_manipulation +*/ + +enum { + FORBID_LOOPEX_DEFAULT = (1<<0), +}; + +static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels) +{ + switch(o->op_type) { + case OP_NEXTSTATE: + case OP_DBSTATE: + { + STRLEN label_len; + U32 label_flags; + const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags); + if(!label_pv) + break; + + SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags); + SAVEFREESV(labelsv); + + sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0))); + break; + } + } + + if(!(o->op_flags & OPf_KIDS)) + return; + + OP *kid = cUNOPo->op_first; + while(kid) { + walk_ops_find_labels(aTHX_ kid, gotolabels); + kid = OpSIBLING(kid); + } +} + +static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname) +{ + bool is_loop = FALSE; + SV *labelsv = NULL; + + switch(o->op_type) { + case OP_NEXTSTATE: + case OP_DBSTATE: + PL_curcop = (COP *)o; + return; + + case OP_RETURN: + goto forbid; + + case OP_GOTO: + { + /* OPf_STACKED means either dynamically computed label or `goto &sub` */ + if(o->op_flags & OPf_STACKED) + goto forbid; + + SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv), + cPVOPo->op_private & OPpPV_IS_UTF8); + SAVEFREESV(target); + + if(hv_fetch_ent(permittedgotos, target, FALSE, 0)) + break; + + goto forbid; + } + + case OP_NEXT: + case OP_LAST: + case OP_REDO: + { + /* OPf_SPECIAL means this is a default loopex */ + if(o->op_flags & OPf_SPECIAL) { + if(flags & FORBID_LOOPEX_DEFAULT) + goto forbid; + + break; + } + /* OPf_STACKED means it's a dynamically computed label */ + if(o->op_flags & OPf_STACKED) + goto forbid; + + SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv)); + if(cPVOPo->op_private & OPpPV_IS_UTF8) + SvUTF8_on(target); + SAVEFREESV(target); + + if(hv_fetch_ent(permittedloops, target, FALSE, 0)) + break; + + goto forbid; + } + + case OP_LEAVELOOP: + { + STRLEN label_len; + U32 label_flags; + const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags); + + if(label_pv) { + labelsv = newSVpvn(label_pv, label_len); + if(label_flags & SVf_UTF8) + SvUTF8_on(labelsv); + SAVEFREESV(labelsv); + + sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0))); + } + + is_loop = TRUE; + break; + } + +forbid: + /* diag_listed_as: Can't "%s" out of a "defer" block */ + /* diag_listed_as: Can't "%s" out of a "finally" block */ + croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname); + + default: + break; + } + + if(!(o->op_flags & OPf_KIDS)) + return; + + OP *kid = cUNOPo->op_first; + while(kid) { + walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname); + kid = OpSIBLING(kid); + + if(is_loop) { + /* Now in the body of the loop; we can permit loopex default */ + flags &= ~FORBID_LOOPEX_DEFAULT; + } + } + + if(is_loop && labelsv) { + HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0); + if(SvIV(HeVAL(he)) > 1) + sv_dec(HeVAL(he)); + else + hv_delete_ent(permittedloops, labelsv, 0, 0); + } +} + +/* +=for apidoc forbid_outofblock_ops + +Checks an optree that implements a block, to ensure there are no control-flow +ops that attempt to leave the block. Any C is forbidden, as is any +C. Loops are analysed, so any LOOPEX op (C, C or +C) that affects a loop that contains it within the block are +permitted, but those that do not are forbidden. + +If any of these forbidden constructions are detected, an exception is thrown +by using the op name and the blockname argument to construct a suitable +message. + +This function alone is not sufficient to ensure the optree does not perform +any of these forbidden activities during runtime, as it might call a different +function that performs a non-local LOOPEX, or a string-eval() that performs a +C, or various other things. It is intended purely as a compile-time +check for those that could be detected statically. Additional runtime checks +may be required depending on the circumstance it is used for. + +Note currently that I C ops are forbidden, even in cases where +they might otherwise be safe to execute. This may be permitted in a later +version. + +=cut +*/ + +void +Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname) +{ + PERL_ARGS_ASSERT_FORBID_OUTOFBLOCK_OPS; + + ENTER; + SAVEVPTR(PL_curcop); - /* 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); + HV *looplabels = newHV(); + SAVEFREESV((SV *)looplabels); - if (AvFILLp(av) != -1) - for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) - { - SvPADTMP_on(*svp); - SvREADONLY_on(*svp); - } - LINKLIST(o); - list(o); - return; -} + HV *gotolabels = newHV(); + SAVEFREESV((SV *)gotolabels); -/* -=head1 Optree Manipulation Functions -*/ + walk_ops_find_labels(aTHX_ o, gotolabels); + + walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname); + + LEAVE; +} /* List constructors */ @@ -6208,18 +5407,18 @@ OP * Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (first->op_type != (unsigned)type - || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) { - return newLISTOP(type, 0, first, last); + return newLISTOP(type, 0, first, last); } - op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); + op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last); first->op_flags |= OPf_KIDS; return first; } @@ -6241,20 +5440,20 @@ OP * Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (first->op_type != (unsigned)type) - return op_prepend_elem(type, first, last); + return op_prepend_elem(type, first, last); if (last->op_type != (unsigned)type) - return op_append_elem(type, first, last); + 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); + OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first); + cLISTOPx(first)->op_last = cLISTOPx(last)->op_last; + OpLASTSIB_set(cLISTOPx(first)->op_last, first); first->op_flags |= (last->op_flags & OPf_KIDS); S_op_destroy(aTHX_ last); @@ -6279,22 +5478,22 @@ OP * Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) { if (!first) - return last; + return last; if (!last) - return first; + return first; if (last->op_type == (unsigned)type) { - if (type == OP_LIST) { /* already a PUSHMARK there */ + 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 + } + else op_sibling_splice(last, NULL, 0, first); - last->op_flags |= OPf_KIDS; - return last; + last->op_flags |= OPf_KIDS; + return last; } return newLISTOP(type, 0, first, last); @@ -6317,24 +5516,27 @@ C to make it the right type. OP * Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) { - dVAR; if (type < 0) type = -type, flags |= OPf_SPECIAL; + if (type == OP_RETURN) { + if (FEATURE_MODULE_TRUE_IS_ENABLED) + flags |= OPf_SPECIAL; + } if (!o || o->op_type != OP_LIST) - o = force_list(o, 0); + o = force_list(o, FALSE); else { - o->op_flags &= ~OPf_WANT; - o->op_private &= ~OPpLVAL_INTRO; + o->op_flags &= ~OPf_WANT; + o->op_private &= ~OPpLVAL_INTRO; } if (!(PL_opargs[type] & OA_MARK)) - op_null(cLISTOPo->op_first); + 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; - } + OP * const kid2 = OpSIBLING(cLISTOPo->op_first); + if (kid2 && kid2->op_type == OP_COREARGS) { + op_null(cLISTOPo->op_first); + kid2->op_private |= OPpCOREARGS_PUSHMARK; + } } if (type != OP_SPLIT) @@ -6346,11 +5548,11 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) o->op_flags |= flags; if (flags & OPf_FOLDED) - o->op_folded = 1; + o->op_folded = 1; o = CHECKOP(type, o); if (o->op_type != (unsigned)type) - return o; + return o; return fold_constants(op_integerize(op_std_init(o))); } @@ -6359,7 +5561,7 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) /* -=head1 Optree construction +=for apidoc_section $optree_construction =for apidoc newNULLLIST @@ -6398,7 +5600,7 @@ S_force_list(pTHX_ OP *o, bool nullit) rest = OpSIBLING(o); OpLASTSIB_set(o, NULL); } - o = newLISTOP(OP_LIST, 0, o, NULL); + o = newLISTOP(OP_LIST, 0, o, NULL); if (rest) op_sibling_splice(o, cLISTOPo->op_last, 0, rest); } @@ -6408,6 +5610,27 @@ S_force_list(pTHX_ OP *o, bool nullit) } /* +=for apidoc op_force_list + +Promotes o and any siblings to be an C if it is not already. If +a new C op was created, its first child will be C. +The returned node itself will be nulled, leaving only its children. + +This is often what you want to do before putting the optree into list +context; as + + o = op_contextualize(op_force_list(o), G_LIST); + +=cut +*/ + +OP * +Perl_op_force_list(pTHX_ OP *o) +{ + return force_list(o, TRUE); +} + +/* =for apidoc newLISTOP Constructs, checks, and returns an op of any list type. C is @@ -6422,6 +5645,9 @@ appropriate. What you want to do in that case is create an op of type C, append more children to it, and then call L. See L for more information. +If a compiletime-known fixed list of child ops is required, the +L function can be used as a convenient shortcut, avoiding the +need to create a temporary plain C in a new variable. =cut */ @@ -6429,7 +5655,6 @@ See L for more information. OP * Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { - dVAR; LISTOP *listop; /* Note that allocating an OP_PUSHMARK can die under Safe.pm if * pushmark is banned. So do it now while existing ops are in a @@ -6437,29 +5662,29 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); NewOp(1101, listop, 1, LISTOP); OpTYPE_set(listop, type); if (first || last) - flags |= OPf_KIDS; + flags |= OPf_KIDS; listop->op_flags = (U8)flags; if (!last && first) - last = first; + last = first; else if (!first && last) - first = last; + first = last; else if (first) - OpMORESIB_set(first, last); + OpMORESIB_set(first, last); listop->op_first = first; listop->op_last = last; if (pushop) { - OpMORESIB_set(pushop, first); - listop->op_first = pushop; - listop->op_flags |= OPf_KIDS; - if (!last) - listop->op_last = pushop; + 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); @@ -6468,6 +5693,45 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } /* +=for apidoc newLISTOPn + +Constructs, checks, and returns an op of any list type. C is +the opcode. C gives the eight bits of C, except that +C will be set automatically if required. The variable number of +arguments after C must all be OP pointers, terminated by a final +C pointer. These will all be consumed as direct children of the list +op and become part of the constructed op tree. + +Do not forget to end the arguments list with a C pointer. + +This function is useful as a shortcut to performing the sequence of +C, C on each element and final +C in the case where a compiletime-known fixed sequence of +child ops is required. If a variable number of elements are required, or for +splicing in an entire sub-list of child ops, see instead L and +L. + +=cut +*/ + +OP * +Perl_newLISTOPn(pTHX_ I32 type, I32 flags, ...) +{ + va_list args; + va_start(args, flags); + + OP *o = newLISTOP(OP_LIST, 0, NULL, NULL); + + OP *kid; + while((kid = va_arg(args, OP *))) + o = op_append_elem(OP_LIST, o, kid); + + va_end(args); + + return op_convert_list(type, flags, o); +} + +/* =for apidoc newOP Constructs, checks, and returns an op of any base type (any type that @@ -6481,18 +5745,17 @@ of C. OP * Perl_newOP(pTHX_ I32 type, I32 flags) { - dVAR; OP *o; if (type == -OP_ENTEREVAL) { - type = OP_ENTEREVAL; - flags |= OPpEVAL_BYTES<<8; + 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); + || (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); @@ -6501,9 +5764,9 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) - scalar(o); + scalar(o); if (PL_opargs[type] & OA_TARGET) - o->op_targ = pad_alloc(type, SVs_PADTMP); + o->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, o); } @@ -6526,27 +5789,27 @@ of the constructed op tree. OP * Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) { - dVAR; UNOP *unop; if (type == -OP_ENTEREVAL) { - type = OP_ENTEREVAL; - flags |= OPpEVAL_BYTES<<8; + 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 ); + || (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_ENTERTRYCATCH + || type == OP_CUSTOM + || type == OP_NULL ); if (!first) - first = newOP(OP_STUB, 0); + first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) - first = force_list(first, 1); + first = op_force_list(first); NewOp(1101, unop, 1, UNOP); OpTYPE_set(unop, type); @@ -6559,7 +5822,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) - return (OP*)unop; + return (OP*)unop; return fold_constants(op_integerize(op_std_init((OP *) unop))); } @@ -6576,7 +5839,6 @@ initialised to C 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 @@ -6615,7 +5877,6 @@ Supported optypes: C. 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 @@ -6623,7 +5884,7 @@ S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth NewOp(1101, methop, 1, METHOP); if (dynamic_meth) { - if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1); + if (PL_opargs[type] & OA_MARK) dynamic_meth = op_force_list(dynamic_meth); methop->op_flags = (U8)(flags | OPf_KIDS); methop->op_u.op_first = dynamic_meth; methop->op_private = (U8)(1 | (flags >> 8)); @@ -6691,26 +5952,44 @@ by this function and become part of the constructed op tree. 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_NULL || type == OP_CUSTOM); - - NewOp(1101, binop, 1, BINOP); + || type == OP_NULL || type == OP_CUSTOM); if (!first) - first = newOP(OP_NULL, 0); + first = newOP(OP_NULL, 0); + else if (type != OP_SASSIGN && S_is_control_transfer(aTHX_ first)) { + /* Skip OP_SASSIGN. + * '$x = return 42' is represented by (SASSIGN (RETURN 42) (GVSV *x)); + * in other words, OP_SASSIGN has its operands "backwards". Skip the + * control transfer check because '$x = return $y' is not a precedence + * issue (the '$x =' part has no runtime effect no matter how you + * parenthesize it). + * Also, don't try to optimize the OP_SASSIGN case because the logical + * assignment ops like //= are represented by an OP_{AND,OR,DOR}ASSIGN + * containing an OP_SASSIGN with a single child (first == last): + * '$x //= return 42' is (DORASSIGN (GVSV *x) (SASSIGN (RETURN 42))). + * Naively eliminating the OP_ASSIGN leaves the incomplete (DORASSIGN + * (GVSV *x) (RETURN 42)), which e.g. B::Deparse doesn't handle. + */ + assert(first != last); + op_free(last); + first->op_folded = 1; + return first; + } + + NewOp(1101, binop, 1, BINOP); 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)); + last = first; + binop->op_private = (U8)(1 | (flags >> 8)); } else { - binop->op_private = (U8)(2 | (flags >> 8)); + binop->op_private = (U8)(2 | (flags >> 8)); OpMORESIB_set(first, last); } @@ -6721,9 +6000,9 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (binop->op_last) OpLASTSIB_set(binop->op_last, (OP*)binop); - binop = (BINOP*)CHECKOP(type, binop); + binop = (BINOP*) CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) - return (OP*)binop; + return (OP*)binop; return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -6746,10 +6025,10 @@ Perl_invmap_dump(pTHX_ SV* invlist, UV *map) PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start); if (end == IV_MAX) { PerlIO_printf(Perl_debug_log, " .. INFTY"); - } - else if (end != start) { + } + else if (end != start) { PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end); - } + } else { PerlIO_printf(Perl_debug_log, " "); } @@ -6812,18 +6091,19 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * One of the important characteristics to know about the input is whether * the transliteration may be done in place, or does a temporary need to be * allocated, then copied. If the replacement for every character in every - * possible string takes up no more bytes than the the character it + * possible string takes up no more bytes than the character it * replaces, then it can be edited in place. Otherwise the replacement - * could "grow", depending on the strings being processed. Some inputs - * won't grow, and might even shrink under /d, but some inputs could grow, - * so we have to assume any given one might grow. On very long inputs, the - * temporary could eat up a lot of memory, so we want to avoid it if - * possible. For non-UTF-8 inputs, everything is single-byte, so can be - * edited in place, unless there is something in the pattern that could - * force it into UTF-8. The inversion map makes it feasible to determine - * this. Previous versions of this code pretty much punted on determining - * if UTF-8 could be edited in place. Now, this code is rigorous in making - * that determination. + * could overwrite a byte we are about to read, depending on the strings + * being processed. The comments and variable names here refer to this as + * "growing". Some inputs won't grow, and might even shrink under /d, but + * some inputs could grow, so we have to assume any given one might grow. + * On very long inputs, the temporary could eat up a lot of memory, so we + * want to avoid it if possible. For non-UTF-8 inputs, everything is + * single-byte, so can be edited in place, unless there is something in the + * pattern that could force it into UTF-8. The inversion map makes it + * feasible to determine this. Previous versions of this code pretty much + * punted on determining if UTF-8 could be edited in place. Now, this code + * is rigorous in making that determination. * * Another characteristic we need to know is whether the lhs and rhs are * identical. If so, and no other flags are present, the only effect of @@ -6841,8 +6121,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * The rhs of the tr/// is here referred to as the r side. */ - SV * const tstr = ((SVOP*)expr)->op_sv; - SV * const rstr = ((SVOP*)repl)->op_sv; + SV * const tstr = cSVOPx(expr)->op_sv; + SV * const rstr = cSVOPx(repl)->op_sv; STRLEN tlen; STRLEN rlen; const U8 * t0 = (U8*)SvPV_const(tstr, tlen); @@ -6860,9 +6140,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH); const bool del = cBOOL(o->op_private & OPpTRANS_DELETE); - /* Set to true if there is some character < 256 in the lhs that maps to > - * 255. If so, a non-UTF-8 match string can be forced into requiring to be - * in UTF-8 by a tr/// operation. */ + /* Set to true if there is some character < 256 in the lhs that maps to + * above 255. If so, a non-UTF-8 match string can be forced into being in + * UTF-8 by a tr/// operation. */ bool can_force_utf8 = FALSE; /* What is the maximum expansion factor in UTF-8 transliterations. If a @@ -6870,14 +6150,14 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * expansion factor is 1.5. This number is used at runtime to calculate * how much space to allocate for non-inplace transliterations. Without * this number, the worst case is 14, which is extremely unlikely to happen - * in real life, and would require significant memory overhead. */ + * in real life, and could require significant memory overhead. */ NV max_expansion = 1.; UV t_range_count, r_range_count, min_range_count; UV* t_array; SV* t_invlist; UV* r_map; - UV r_cp, t_cp; + UV r_cp = 0, t_cp = 0; UV t_cp_end = (UV) -1; UV r_cp_end; Size_t len; @@ -6904,30 +6184,29 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * these up into smaller chunks, but doesn't merge any together. This * makes it easy to find the instances it's looking for. A second pass is * done after this has been determined which merges things together to - * shrink the table for runtime. For ASCII platforms, the table is - * trivial, given below, and uses the fundamental characteristics of UTF-8 - * to construct the values. For EBCDIC, it isn't so, and we rely on a - * table constructed by the perl script that generates these kinds of - * things */ -#ifndef EBCDIC + * shrink the table for runtime. The table below is used for both ASCII + * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically + * increasing for code points below 256. To correct for that, the macro + * CP_ADJUST defined below converts those code points to ASCII in the first + * pass, and we use the ASCII partition values. That works because the + * growth factor will be unaffected, which is all that is calculated during + * the first pass. */ UV PL_partition_by_byte_length[] = { 0, - 0x80, - (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), - (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), - ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), - ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), - ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) + 0x80, /* Below this is 1 byte representations */ + (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */ + (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */ + ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */ + ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */ + ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */ # ifdef UV_IS_QUAD , - ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) + ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */ # endif }; -#endif - PERL_ARGS_ASSERT_PMTRANS; PL_hints |= HINT_BLOCK_SCOPE; @@ -7028,10 +6307,21 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* Initialize to a single range */ t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX); - /* For the first pass, the lhs is partitioned such that the - * number of UTF-8 bytes required to represent a code point in each - * partition is the same as the number for any other code point in - * that partion. We copy the pre-compiled partion. */ + /* Below, we parse the (potentially adjusted) input, creating the inversion + * map. This is done in two passes. The first pass is just to determine + * if the transliteration can be done in-place. It can be done in place if + * no possible inputs result in the replacement taking up more bytes than + * the input. To figure that out, in the first pass we start with all the + * possible code points partitioned into ranges so that every code point in + * a range occupies the same number of UTF-8 bytes as every other code + * point in the range. Constructing the inversion map doesn't merge ranges + * together, but can split them into multiple ones. Given the starting + * partition, the ending state will also have the same characteristic, + * namely that each code point in each partition requires the same number + * of UTF-8 bytes to represent as every other code point in the same + * partition. + * + * This partitioning has been pre-compiled. Copy it to initialize */ len = C_ARRAY_LENGTH(PL_partition_by_byte_length); invlist_extend(t_invlist, len); t_array = invlist_array(t_invlist); @@ -7039,22 +6329,33 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist))); Newx(r_map, len + 1, UV); - /* Parse the (potentially adjusted) input, creating the inversion map. - * This is done in two passes. The first pass is to determine if the - * transliteration can be done in place. The inversion map it creates - * could be used, but generally would be larger and slower to run than the - * output of the second pass, which starts with a more compact table and - * allows more ranges to be merged */ + /* The inversion map the first pass creates could be used as-is, but + * generally would be larger and slower to run than the output of the + * second pass. */ + for (pass2 = 0; pass2 < 2; pass2++) { if (pass2) { - /* Initialize to a single range */ + /* In the second pass, we start with a single range */ t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX); - - /* In the second pass, we just have the single range */ len = 1; t_array = invlist_array(t_invlist); } +/* As noted earlier, we convert EBCDIC code points to Unicode in the first pass + * so as to get the well-behaved length 1 vs length 2 boundary. Only code + * points below 256 differ between the two character sets in this regard. For + * these, we also can't have any ranges, as they have to be individually + * converted. */ +#ifdef EBCDIC +# define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x)) +# define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256)) +# define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x)) +#else +# define CP_ADJUST(x) (x) +# define FORCE_RANGE_LEN_1(x) 0 +# define CP_SKIP(x) UVCHR_SKIP(x) +#endif + /* And the mapping of each of the ranges is initialized. Initially, * everything is TR_UNLISTED. */ for (i = 0; i < len; i++) { @@ -7188,7 +6489,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* Here, not in the middle of a range, and not UTF-8. The * next code point is the single byte where we're at */ - t_cp = *t; + t_cp = CP_ADJUST(*t); t_range_count = 1; t++; } @@ -7199,7 +6500,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * next code point is the next UTF-8 char in the input. We * know the input is valid, because the toker constructed * it */ - t_cp = valid_utf8_to_uvchr(t, &t_char_len); + t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len)); t += t_char_len; /* UTF-8 strings (only) have been parsed in toke.c to have @@ -7207,7 +6508,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * the first element of a range. If so, get the final * element and calculate the range size. If not, the range * size is 1 */ - if (t < tend && *t == RANGE_INDICATOR) { + if ( t < tend && *t == RANGE_INDICATOR + && ! FORCE_RANGE_LEN_1(t_cp)) + { t++; t_range_count = valid_utf8_to_uvchr(t, &t_char_len) - t_cp + 1; @@ -7239,16 +6542,18 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } else { if (! rstr_utf8) { - r_cp = *r; + r_cp = CP_ADJUST(*r); r_range_count = 1; r++; } else { Size_t r_char_len; - r_cp = valid_utf8_to_uvchr(r, &r_char_len); + r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len)); r += r_char_len; - if (r < rend && *r == RANGE_INDICATOR) { + if ( r < rend && *r == RANGE_INDICATOR + && ! FORCE_RANGE_LEN_1(r_cp)) + { r++; r_range_count = valid_utf8_to_uvchr(r, &r_char_len) - r_cp + 1; @@ -7317,7 +6622,12 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t_cp_end = MIN(IV_MAX, t_cp + span - 1); if (r_cp == TR_SPECIAL_HANDLING) { - r_cp_end = TR_SPECIAL_HANDLING; + + /* If unmatched lhs code points map to the final map, use that + * value. This being set to TR_SPECIAL_HANDLING indicates that + * we don't have a final map: unmatched lhs code points are + * simply deleted */ + r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map; } else { r_cp_end = MIN(IV_MAX, r_cp + span - 1); @@ -7347,6 +6657,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * we use the above sample data. The t_cp chunk must be any * contiguous subset of M, N, O, P, and/or Q. * + * In the first pass, calculate if there is any possible input + * string that has a character whose transliteration will be + * longer than it. If none, the transliteration may be done + * in-place, as it can't write over a so-far unread byte. + * Otherwise, a copy must first be made. This could be + * expensive for long inputs. + * * In the first pass, the t_invlist has been partitioned so * that all elements in any single range have the same number * of bytes in their UTF-8 representations. And the r space is @@ -7368,21 +6685,31 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * code point in the rhs against any code point in the lhs. */ if ( ! pass2 && r_cp_end != TR_SPECIAL_HANDLING - && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end)) + && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end)) { - /* Consider tr/\xCB/\X{E000}/. The maximum expansion - * factor is 1 byte going to 3 if the lhs is not UTF-8, but - * 2 bytes going to 3 if it is in UTF-8. We could pass two - * different values so doop could choose based on the - * UTF-8ness of the target. But khw thinks (perhaps - * wrongly) that is overkill. It is used only to make sure - * we malloc enough space. If no target string can force - * the result to be UTF-8, then we don't have to worry - * about this */ + /* Here, we will need to make a copy of the input string + * before doing the transliteration. The worst possible + * case is an expansion ratio of 14:1. This is rare, and + * we'd rather allocate only the necessary amount of extra + * memory for that copy. We can calculate the worst case + * for this particular transliteration is by keeping track + * of the expansion factor for each range. + * + * Consider tr/\xCB/\X{E000}/. The maximum expansion + * factor is 1 byte going to 3 if the target string is not + * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We + * could pass two different values so doop could choose + * based on the UTF-8ness of the target. But khw thinks + * (perhaps wrongly) that is overkill. It is used only to + * make sure we malloc enough space. + * + * If no target string can force the result to be UTF-8, + * then we don't have to worry about the case of the target + * string not being UTF-8 */ NV t_size = (can_force_utf8 && t_cp < 256) ? 1 - : UVCHR_SKIP(t_cp_end); - NV ratio = UVCHR_SKIP(r_cp_end) / t_size; + : CP_SKIP(t_cp_end); + NV ratio = CP_SKIP(r_cp_end) / t_size; o->op_private |= OPpTRANS_GROWS; @@ -7415,8 +6742,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * is if it 'grows'. But in the 2nd pass, there's no * reason to not merge */ if ( (i > 0 && ( pass2 - || UVCHR_SKIP(t_array[i-1]) - == UVCHR_SKIP(t_cp))) + || CP_SKIP(t_array[i-1]) + == CP_SKIP(t_cp))) && ( ( r_cp == TR_SPECIAL_HANDLING && r_map[i-1] == TR_SPECIAL_HANDLING) || ( r_cp != TR_SPECIAL_HANDLING @@ -7436,7 +6763,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) adjacent_to_range_above = TRUE; if (i + 1 < len) if ( ( pass2 - || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1])) + || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1])) && ( ( r_cp == TR_SPECIAL_HANDLING && r_map[i+1] == (UV) TR_SPECIAL_HANDLING) || ( r_cp != TR_SPECIAL_HANDLING @@ -7692,10 +7019,10 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) * except for the count, and streamlined runtime code can be used */ if (!del && !squash) { - /* They are identical if they point to same address, or if everything - * maps to UNLISTED or to itself. This catches things that not looking - * at the normalized inversion map doesn't catch, like tr/aa/ab/ or - * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */ + /* They are identical if they point to the same address, or if + * everything maps to UNLISTED or to itself. This catches things that + * not looking at the normalized inversion map doesn't catch, like + * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */ if (r0 != t0) { for (i = 0; i < len; i++) { if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) { @@ -7725,6 +7052,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) || r_map[len-1] == TR_SPECIAL_HANDLING)))) { SV* r_map_sv; + SV* temp_sv; /* A UTF-8 op is generated, indicated by this flag. This op is an * sv_op */ @@ -7735,20 +7063,27 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } /* The inversion map is pushed; first the list. */ - invmap = MUTABLE_AV(newAV()); + invmap = MUTABLE_AV(newAV()); + + SvREADONLY_on(t_invlist); av_push(invmap, t_invlist); /* 2nd is the mapping */ r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV)); + SvREADONLY_on(r_map_sv); av_push(invmap, r_map_sv); /* 3rd is the max possible expansion factor */ - av_push(invmap, newSVnv(max_expansion)); + temp_sv = newSVnv(max_expansion); + SvREADONLY_on(temp_sv); + av_push(invmap, temp_sv); /* Characters that are in the search list, but not in the replacement * list are mapped to the final character in the replacement list */ if (! del && r_count < t_count) { - av_push(invmap, newSVuv(final_map)); + temp_sv = newSVuv(final_map); + SvREADONLY_on(temp_sv); + av_push(invmap, temp_sv); } #ifdef USE_ITHREADS @@ -7771,14 +7106,13 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) + (256 - 1 + 1)*sizeof(short); /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup - * table. Entries with the value TR_UNMAPPED indicate chars not to be - * translated, while TR_DELETE indicates a search char without a - * corresponding replacement char under /d. - * - * In addition, an extra slot at the end is used to store the final - * repeating char, or TR_R_EMPTY under an empty replacement list, or - * TR_DELETE under /d; which makes the runtime code easier. - */ + * table. Entries with the value TR_UNMAPPED indicate chars not to be + * translated, while TR_DELETE indicates a search char without a + * corresponding replacement char under /d. + * + * In addition, an extra slot at the end is used to store the final + * repeating char, or TR_R_EMPTY under an empty replacement list, or + * TR_DELETE under /d; which makes the runtime code easier. */ /* Indicate this is an op_pv */ o->op_private &= ~OPpTRANS_USE_SVOP; @@ -7879,9 +7213,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) Safefree(r_map); if(del && rlen != 0 && r_count == t_count) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); } else if(r_count > t_count) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } op_free(expr); @@ -7904,29 +7238,28 @@ and, shifted up eight bits, the eight bits of C. OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { - dVAR; PMOP *pmop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP - || type == OP_CUSTOM); + || 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); + scalar((OP *)pmop); if (PL_hints & HINT_RE_TAINT) - pmop->op_pmflags |= PMf_RETAINT; + pmop->op_pmflags |= PMf_RETAINT; #ifdef USE_LOCALE_CTYPE if (IN_LC_COMPILETIME(LC_CTYPE)) { - set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); + 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); + set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_ @@ -7945,23 +7278,23 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) #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); + /* 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); + assert(SvCUR(repointer_list) % sizeof(IV) == 0); - SvEND_set(repointer_list, p); + 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); + 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); + SV * const repointer = &PL_sv_undef; + av_push(PL_regex_padav, repointer); + pmop->op_pmoffset = av_top_index(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); } #endif @@ -7975,11 +7308,11 @@ S_set_haseval(pTHX) 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); + 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); } } @@ -8049,7 +7382,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) } } else if (expr->op_type != OP_CONST) - is_compiletime = 0; + is_compiletime = 0; LINKLIST(expr); @@ -8107,7 +7440,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) /* have to peep the DOs individually as we've removed it from * the op_next chain */ CALL_PEEP(child); - S_prune_chain_head(&(child->op_next)); + op_prune_chain_head(&(child->op_next)); if (is_compiletime) /* runtime finalizes as part of finalizing whole tree */ finalize_optree(child); @@ -8121,12 +7454,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) } PL_hints |= HINT_BLOCK_SCOPE; - pm = (PMOP*)o; + pm = cPMOPo; 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(); + U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; + regexp_engine const *eng = current_re_engine(); if (is_split) { /* make engine handle split ' ' specially */ @@ -8134,30 +7467,30 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) 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. - */ + 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)) { + SSize_t i = 0; + assert(PadnamelistMAXNAMED(PL_comppad_name) == 0); + while (++i <= AvFILLp(PL_comppad)) { # ifdef USE_PAD_RESET /* under USE_PAD_RESET, pad swipe replaces a swiped * folded constant with a fresh padtmp */ - assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); + assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i])); # else - assert(!PL_curpad[i]); + assert(!PL_curpad[i]); # endif - } + } #endif /* This LEAVE_SCOPE will restore PL_compcv to point to the * outer CV (the one whose slab holds the pm op). The @@ -8166,212 +7499,210 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) * return from this function. Which is why its safe to * call op_free(expr) below. */ - LEAVE_SCOPE(floor); - pm->op_pmflags &= ~PMf_HAS_CV; - } + LEAVE_SCOPE(floor); + pm->op_pmflags &= ~PMf_HAS_CV; + } /* Skip compiling if parser found an error for this pattern */ if (pm->op_pmflags & PMf_HAS_ERROR) { return o; } - 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 */ + 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; + REGEXP* re; /* Skip compiling if parser found an error for this pattern */ if (pm->op_pmflags & PMf_HAS_ERROR) { return o; } - 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; - } - } + 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); + cPMOPx(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; - } + /* 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 (is_split) /* make engine handle split ' ' specially */ 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)); - } + /* 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 + * entersub + * regcreset regcreset + * pushmark pushmark + * const("a") const("a") + * gvsv(b) gvsv(b) + * const("(?{...})") const("(?{...})") + * leavesub + * regcomp regcomp + */ - rcop = alloc_LOGOP(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; + SvREFCNT_inc_simple_void(PL_compcv); + CvLVALUE_on(PL_compcv); + /* these lines are just an unrolled newANONATTRSUB */ + expr = newSVOP(OP_ANONCODE, OPf_REF, + MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); + cv_targ = expr->op_targ; - /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ - if (PL_hints & HINT_RE_EVAL) - S_set_haseval(aTHX); + expr = list(op_force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); + } - /* 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; - } + rcop = alloc_LOGOP(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; + cUNOPx(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); + 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 + 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 { + 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 = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o); - rcop->op_private = 1; + rcop->op_private = 1; - /* establish postfix order */ - rcop->op_next = LINKLIST(repl); - repl->op_next = (OP*)rcop; + /* 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; - } + 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; @@ -8391,15 +7722,17 @@ takes ownership of one reference to it. OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { - dVAR; SVOP *svop; PERL_ARGS_ASSERT_NEWSVOP; + /* OP_RUNCV is allowed specially so rpeep has room to convert it into an + * OP_CONST */ 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); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_RUNCV + || type == OP_CUSTOM); NewOp(1101, svop, 1, SVOP); OpTYPE_set(svop, type); @@ -8408,9 +7741,9 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) svop->op_flags = (U8)flags; svop->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)svop); + scalar((OP*)svop); if (PL_opargs[type] & OA_TARGET) - svop->op_targ = pad_alloc(type, SVs_PADTMP); + svop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, svop); } @@ -8425,7 +7758,7 @@ Constructs and returns an op to access C<$_>. OP * Perl_newDEFSVOP(pTHX) { - return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); + return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } #ifdef USE_ITHREADS @@ -8447,29 +7780,28 @@ This function only exists if Perl has been compiled to use ithreads. 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); + || (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); + 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); + scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) - padop->op_targ = pad_alloc(type, SVs_PADTMP); + padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } @@ -8515,15 +7847,14 @@ have been allocated using C. 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); + || type == OP_CUSTOM + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); OpTYPE_set(pvop, type); @@ -8532,9 +7863,9 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) pvop->op_flags = (U8)flags; pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0; if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)pvop); + scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) - pvop->op_targ = pad_alloc(type, SVs_PADTMP); + pvop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, pvop); } @@ -8569,6 +7900,37 @@ Perl_package_version( pTHX_ OP *v ) op_free(v); } +/* Extract the first two components of a "version" object as two 8bit integers + * and return them packed into a single U16 in the format of PL_prevailing_version. + * This function only ever has to cope with version objects already known + * bounded by the current perl version, so we know its components will fit + * (Up until we reach perl version 5.256 anyway) */ +static U16 S_extract_shortver(pTHX_ SV *sv) +{ + SV *rv; + if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version")) + return 0; + + AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0))); + + U16 shortver = 0; + + IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0; + if(major > 255) + shortver |= 255 << 8; + else + shortver |= major << 8; + + IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0; + if(minor > 255) + shortver |= 255; + else + shortver |= minor; + + return shortver; +} +#define SHORTVER(maj,min) ((maj << 8) | min) + void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { @@ -8580,98 +7942,111 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PERL_ARGS_ASSERT_UTILIZE; if (idop->op_type != OP_CONST) - Perl_croak(aTHX_ "Module name must be constant"); + 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"); + SV * const vesv = cSVOPx(version)->op_sv; - /* 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))); - } + 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(cSVOPx(idop)->op_sv)); + + /* Fake up a method call to VERSION */ + meth = newSVpvs_share("VERSION"); + veop = newLISTOPn(OP_ENTERSUB, OPf_STACKED, + pack, + version, + newMETHOP_named(OP_METHOD_NAMED, 0, meth), + NULL); + } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { - imop = arg; /* no import on explicit () */ + 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 if (SvNIOKp(cSVOPx(idop)->op_sv)) { + imop = NULL; /* use 5.0; */ + if (aver) + use_version = cSVOPx(idop)->op_sv; + else + idop->op_private |= OPpCONST_NOVER; } else { - SV *meth; + SV *meth; - /* Make copy of idop so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(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 a method call to import/unimport */ + meth = aver + ? newSVpvs_share("import") : newSVpvs_share("unimport"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED, + 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) )); + 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; - } + /* 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); + + U16 shortver = S_extract_shortver(aTHX_ use_version); + + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (shortver >= SHORTVER(5, 11)) { + 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; + + if (shortver >= SHORTVER(5, 35) && !(PL_dowarn & G_WARN_ALL_MASK)) { + free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); + PL_dowarn |= G_WARN_ONCE; + } + } + /* otherwise they are off */ + else { + if(PL_prevailing_version >= SHORTVER(5, 11)) + deprecate_fatal_in(WARN_DEPRECATED__VERSION_DOWNGRADE, "5.40", + "Downgrading a use VERSION declaration to below v5.11"); + + 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; + } + + PL_prevailing_version = shortver; } /* The "did you use incorrect case?" warning used to be here. @@ -8697,11 +8072,12 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) } /* -=head1 Embedding Functions +=for apidoc_section $embedding -=for apidoc load_module +=for apidoc load_module +=for apidoc_item load_module_nocontext -Loads the module whose name is pointed to by the string part of C. +These load the module whose name is pointed to by the string part of C. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL, provides version semantics similar to C. The optional @@ -8726,10 +8102,17 @@ decremented. In addition, the C argument is modified. If C is set, the module is loaded as if with C rather than C. +C and C have the same apparent signature, +but the former hides the fact that it is accessing a thread context parameter. +So use the latter when you get a compilation error about C. + =for apidoc Amnh||PERL_LOADMOD_DENY =for apidoc Amnh||PERL_LOADMOD_NOIMPORT =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS +=for apidoc vload_module +Like C> but the arguments are an encapsulated argument list. + =cut */ void @@ -8744,7 +8127,7 @@ Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) va_end(args); } -#ifdef PERL_IMPLICIT_CONTEXT +#ifdef MULTIPLICITY void Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) { @@ -8786,24 +8169,24 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) modname = newSVOP(OP_CONST, 0, name); modname->op_private |= OPpCONST_BARE; if (ver) { - veop = newSVOP(OP_CONST, 0, ver); + veop = newSVOP(OP_CONST, 0, ver); } else - veop = NULL; + veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { - imop = sawparens(newNULLLIST()); + imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { - imop = va_arg(*args, OP*); + 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*); - } + 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(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop); @@ -8814,9 +8197,9 @@ 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)))); + newLISTOP(OP_LIST, 0, arg, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv)))); } OP * @@ -8828,16 +8211,16 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin) PERL_ARGS_ASSERT_DOFILE; if (!force_builtin && (gv = gv_override("do", 2))) { - doop = S_new_entersubop(aTHX_ gv, term); + doop = S_new_entersubop(aTHX_ gv, term); } else { - doop = newUNOP(OP_DOFILE, 0, scalar(term)); + doop = newUNOP(OP_DOFILE, 0, scalar(term)); } return doop; } /* -=head1 Optree construction +=for apidoc_section $optree_construction =for apidoc newSLICEOP @@ -8856,8 +8239,8 @@ 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)) ); + list(op_force_list(subscript)), + list(op_force_list(listval))); } #define ASSIGN_SCALAR 0 @@ -8878,24 +8261,24 @@ S_assignment_type(pTHX_ const OP *o) U8 ret; if (!o) - return ASSIGN_LIST; + return ASSIGN_LIST; if (o->op_type == OP_SREFGEN) { - OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; - type = kid->op_type; - flags = o->op_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; + OP * const kid = cUNOPx(cUNOPo->op_first)->op_first; + type = kid->op_type; + flags = o->op_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 { - if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) - o = cUNOPo->op_first; - flags = o->op_flags; - type = o->op_type; - ret = ASSIGN_SCALAR; + if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS)) + o = cUNOPo->op_first; + flags = o->op_flags; + type = o->op_type; + ret = ASSIGN_SCALAR; } if (type == OP_COND_EXPR) { @@ -8903,29 +8286,29 @@ S_assignment_type(pTHX_ const OP *o) 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 ASSIGN_SCALAR; + 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 ASSIGN_SCALAR; } if (type == OP_LIST && - (flags & OPf_WANT) == OPf_WANT_SCALAR && - o->op_private & OPpLVAL_INTRO) - return ret; + (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_RV2AV || type == OP_RV2HV || + type == OP_ASLICE || type == OP_HSLICE || type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN) - return ASSIGN_LIST; + return ASSIGN_LIST; if (type == OP_PADAV || type == OP_PADHV) - return ASSIGN_LIST; + return ASSIGN_LIST; if (type == OP_RV2SV) - return ret; + return ret; return ret; } @@ -8933,21 +8316,19 @@ S_assignment_type(pTHX_ const OP *o) static OP * S_newONCEOP(pTHX_ OP *initop, OP *padop) { - dVAR; const PADOFFSET target = padop->op_targ; OP *const other = newOP(OP_PADSV, - padop->op_flags - | ((padop->op_private & ~OPpLVAL_INTRO) << 8)); + padop->op_flags + | ((padop->op_private & ~OPpLVAL_INTRO) << 8)); OP *const first = newOP(OP_NULL, 0); OP *const nullop = newCONDOP(0, first, initop, other); /* XXX targlex disabled for now; see ticket #124160 - newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other); + newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), 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. */ @@ -8960,6 +8341,32 @@ S_newONCEOP(pTHX_ OP *initop, OP *padop) } /* +=for apidoc newARGDEFELEMOP + +Constructs and returns a new C op which provides a defaulting +expression given by C for the signature parameter at the index given +by C. The expression optree is consumed by this function and +becomes part of the returned optree. + +=cut +*/ + +OP * +Perl_newARGDEFELEMOP(pTHX_ I32 flags, OP *expr, I32 argindex) +{ + PERL_ARGS_ASSERT_NEWARGDEFELEMOP; + + OP *o = (OP *)alloc_LOGOP(OP_ARGDEFELEM, expr, LINKLIST(expr)); + o->op_flags |= (U8)(flags); + o->op_private = 1 | (U8)(flags >> 8); + + /* re-purpose op_targ to hold @_ index */ + o->op_targ = (PADOFFSET)(argindex); + + return o; +} + +/* =for apidoc newASSIGNOP Constructs, checks, and returns an assignment op. C and C @@ -8988,83 +8395,84 @@ 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) { + switch (optype) { + case 0: break; + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: right = scalar(right); - return newLOGOP(optype, 0, - op_lvalue(scalar(left), optype), - newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); - } - else { - return newBINOP(optype, OPf_STACKED, - op_lvalue(scalar(left), optype), scalar(right)); - } + return newLOGOP(optype, 0, + op_lvalue(scalar(left), optype), + newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); + default: + return newBINOP(optype, OPf_STACKED, + op_lvalue(scalar(left), optype), scalar(right)); } if ((assign_type = assignment_type(left)) == ASSIGN_LIST) { - OP *state_var_op = NULL; - static const char no_list_state[] = "Initialization of state variables" - " in list currently forbidden"; - OP *curop; - - 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, *vop, *eop; - if (!(left->op_flags & OPf_PARENS) && - lop->op_type == OP_PUSHMARK && - (vop = OpSIBLING(lop)) && - (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) && - !(vop->op_flags & OPf_PARENS) && - (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == - (OPpLVAL_INTRO|OPpPAD_STATE) && - (eop = OpSIBLING(vop)) && - eop->op_type == OP_ENTERSUB && - !OpHAS_SIBLING(eop)) { - state_var_op = vop; - } else { - while (lop) { - if ((lop->op_type == OP_PADSV || - lop->op_type == OP_PADAV || - lop->op_type == OP_PADHV || - lop->op_type == OP_PADANY) - && (lop->op_private & OPpPAD_STATE) - ) - yyerror(no_list_state); - lop = OpSIBLING(lop); - } - } - } - else if ( (left->op_private & OPpLVAL_INTRO) + OP *state_var_op = NULL; + static const char no_list_state[] = "Initialization of state variables" + " in list currently forbidden"; + OP *curop; + + 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(op_force_list(left)); + o = newBINOP(OP_AASSIGN, flags, list(op_force_list(right)), curop); + o->op_private = (U8)(0 | (flags >> 8)); + + if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) + { + OP *lop = cLISTOPx(left)->op_first, *vop, *eop; + if (!(left->op_flags & OPf_PARENS) && + lop->op_type == OP_PUSHMARK && + (vop = OpSIBLING(lop)) && + (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) && + !(vop->op_flags & OPf_PARENS) && + (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) == + (OPpLVAL_INTRO|OPpPAD_STATE) && + (eop = OpSIBLING(vop)) && + eop->op_type == OP_ENTERSUB && + !OpHAS_SIBLING(eop)) { + state_var_op = vop; + } else { + while (lop) { + if ((lop->op_type == OP_PADSV || + lop->op_type == OP_PADAV || + lop->op_type == OP_PADHV || + lop->op_type == OP_PADANY) + && (lop->op_private & OPpPAD_STATE) + ) + yyerror(no_list_state); + lop = OpSIBLING(lop); + } + } + } + else if ( (left->op_private & OPpLVAL_INTRO) && (left->op_private & OPpPAD_STATE) - && ( left->op_type == OP_PADSV - || left->op_type == OP_PADAV - || left->op_type == OP_PADHV - || left->op_type == OP_PADANY) + && ( left->op_type == OP_PADSV + || left->op_type == OP_PADAV + || left->op_type == OP_PADHV + || left->op_type == OP_PADANY) ) { - /* All single variable list context state assignments, hence - state ($a) = ... - (state $a) = ... - state @a = ... - state (@a) = ... - (state @a) = ... - state %a = ... - state (%a) = ... - (state %a) = ... - */ + /* All single variable list context state assignments, hence + state ($a) = ... + (state $a) = ... + state @a = ... + state (@a) = ... + (state @a) = ... + state %a = ... + state (%a) = ... + (state %a) = ... + */ if (left->op_flags & OPf_PARENS) - yyerror(no_list_state); - else - state_var_op = left; - } + yyerror(no_list_state); + else + state_var_op = left; + } /* optimise @a = split(...) into: * @{expr}: split(..., @{expr}) (where @a is not flattened) @@ -9072,7 +8480,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * the split op itself) */ - if ( right + if ( right && right->op_type == OP_SPLIT /* don't do twice, e.g. @b = (@a = split) */ && !(right->op_private & OPpSPLIT_ASSIGN)) @@ -9080,18 +8488,18 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP *gvop = NULL; if ( ( left->op_type == OP_RV2AV - && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV) + && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV) || left->op_type == OP_PADAV) { /* @pkg or @lex or local @pkg' or 'my @lex' */ OP *tmpop; if (gvop) { #ifdef USE_ITHREADS - ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff + cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = cPADOPx(gvop)->op_padix; cPADOPx(gvop)->op_padix = 0; /* steal it */ #else - ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv + cPMOPx(right)->op_pmreplrootu.op_pmtargetgv = MUTABLE_GV(cSVOPx(gvop)->op_sv); cSVOPx(gvop)->op_sv = NULL; /* steal it */ #endif @@ -9099,7 +8507,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) left->op_private & OPpOUR_INTRO; } else { - ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ; + cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ; left->op_targ = 0; /* steal it */ right->op_private |= OPpSPLIT_LEX; } @@ -9107,7 +8515,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) detach_split: tmpop = cUNOPo->op_first; /* to list (nulled) */ - tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ + tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */ assert(OpSIBLING(tmpop) == right); assert(!OpHAS_SIBLING(right)); /* detach the split subtreee from the o tree, @@ -9134,11 +8542,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) goto detach_split; } else if (PL_modcount < RETURN_UNLIMITED_NUMBER && - ((LISTOP*)right)->op_last->op_type == OP_CONST) + cLISTOPx(right)->op_last->op_type == OP_CONST) { /* convert split(...,0) to split(..., PL_modcount+1) */ SV ** const svp = - &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + &cSVOPx(cLISTOPx(right)->op_last)->op_sv; SV * const sv = *svp; if (SvIOK(sv) && SvIVX(sv) == 0) { @@ -9154,24 +8562,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } } - } + } - if (state_var_op) - o = S_newONCEOP(aTHX_ o, state_var_op); - return o; + if (state_var_op) + o = S_newONCEOP(aTHX_ o, state_var_op); + return o; } if (assign_type == ASSIGN_REF) - return newBINOP(OP_REFASSIGN, flags, scalar(right), left); + return newBINOP(OP_REFASSIGN, flags, scalar(right), left); if (!right) - right = newOP(OP_UNDEF, 0); + 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)); + 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) ); + o = newBINOP(OP_SASSIGN, flags, + scalar(right), op_lvalue(scalar(left), OP_SASSIGN) ); } return o; } @@ -9197,11 +8605,11 @@ is consumed by this function and becomes part of the returned op tree. OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - dVAR; const U32 seq = intro_my(); const U32 utf8 = flags & SVf_UTF8; COP *cop; + assert(PL_parser); PL_parser->parsed_sub = 0; flags &= ~SVf_UTF8; @@ -9223,14 +8631,15 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_seq = seq; cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); + CopFEATURES_setfrom(cop, PL_curcop); if (label) { - Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + 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); + 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) { @@ -9240,30 +8649,30 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) else if (PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); else { - CopLINE_set(cop, PL_parser->copline); - PL_parser->copline = NOLINE; + CopLINE_set(cop, PL_parser->copline); + PL_parser->copline = NOLINE; } #ifdef USE_ITHREADS - CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ + CopFILE_copy(cop, PL_curcop); #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)); - } - } + /* 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); + op_null((OP*)cop); return op_prepend_elem(OP_LINESEQ, (OP*)cop, o); } @@ -9302,43 +8711,43 @@ S_search_const(pTHX_ OP *o) redo: switch (o->op_type) { - case OP_CONST: - return o; - case OP_NULL: - if (o->op_flags & OPf_KIDS) { - o = cUNOPo->op_first; + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) { + o = cUNOPo->op_first; goto redo; } - 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; + 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: - o = kid; + o = kid; goto redo; - } + } } return NULL; @@ -9348,7 +8757,6 @@ S_search_const(pTHX_ OP *o) STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { - dVAR; LOGOP *logop; OP *o; OP *first; @@ -9361,147 +8769,115 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first = *firstp; other = *otherp; - /* [perl #59802]: Warn about things like "return $a or $b", which - is parsed as "(return $a) or $b" rather than "return ($a or - $b)". NB: This also applies to xor, which is why we do it - here. - */ - switch (first->op_type) { - case OP_NEXT: - case OP_LAST: - case OP_REDO: - /* XXX: Perhaps we should emit a stronger warning for these. - Even with the high-precedence operator they don't seem to do - anything sensible. - - But until we do, fall through here. - */ - case OP_RETURN: - case OP_EXIT: - case OP_DIE: - case OP_GOTO: - /* XXX: Currently we allow people to "shoot themselves in the - foot" by explicitly writing "(return $a) or $b". - - Warn unless we are looking at the result from folding or if - the programmer explicitly grouped the operators like this. - The former can occur with e.g. - - use constant FEATURE => ( $] >= ... ); - sub { not FEATURE and return or do_stuff(); } - */ - if (!first->op_folded && !(first->op_flags & OPf_PARENS)) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Possible precedence issue with control flow operator"); - /* XXX: Should we optimze this to "return $a;" (i.e. remove - the "or $b" part)? - */ - break; - } - if (type == OP_XOR) /* Not short circuit, but here by precedence. */ - return newBINOP(type, flags, scalar(first), scalar(other)); + return newBINOP(type, flags, scalar(first), scalar(other)); assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); scalarboolean(first); + if (S_is_control_transfer(aTHX_ first)) { + op_free(other); + first->op_folded = 1; + return first; + } + /* 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))) { + 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(cSVOPx(cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(cSVOPx(cstop)->op_sv)) || + (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) { /* Elide the (constant) lhs, since it can't affect the outcome */ - *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 { + *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 { /* Elide the rhs, since the outcome is entirely determined by * the (constant) lhs */ - /* check for C, or C */ - 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)) - { + /* check for C, or C */ + 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_croak(aTHX_ "This use of my() in false conditional is " "no longer allowed"); - } + } - *otherp = NULL; - if (cstop->op_type == OP_CONST) - cstop->op_private |= OPpCONST_SHORTCIRCUIT; + *otherp = NULL; + if (cstop->op_type == OP_CONST) + cstop->op_private |= OPpCONST_SHORTCIRCUIT; op_free(other); - return first; - } + return first; + } } else if ((first->op_flags & OPf_KIDS) && type != OP_DOR - && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ + && ckWARN(WARN_MISC)) /* [#24076] Don't warn for 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) + const OP * const k1 = cUNOPx(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); + { + 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); - } + 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); + } } /* optimize AND and OR ops that have NOTs as children */ @@ -9536,8 +8912,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); o = newUNOP(prepend_not ? OP_NOT : OP_NULL, - PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, - (OP*)logop); + PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0, + (OP*)logop); other->op_next = o; return o; @@ -9560,7 +8936,6 @@ this function and become part of the constructed op tree. OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { - dVAR; LOGOP *logop; OP *start; OP *o; @@ -9569,30 +8944,37 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) PERL_ARGS_ASSERT_NEWCONDOP; if (!falseop) - return newLOGOP(OP_AND, 0, first, trueop); + return newLOGOP(OP_AND, 0, first, trueop); if (!trueop) - return newLOGOP(OP_OR, 0, first, falseop); + return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); + if (S_is_control_transfer(aTHX_ first)) { + op_free(trueop); + op_free(falseop); + first->op_folded = 1; + return 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; + /* Left or right arm of the conditional? */ + const bool left = SvTRUE(cSVOPx(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); - } + 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; + 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 = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_flags |= (U8)flags; @@ -9600,7 +8982,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ - logop); + logop); /* establish postfix order */ start = LINKLIST(first); @@ -9619,6 +9001,63 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) } /* +=for apidoc newTRYCATCHOP + +Constructs and returns a conditional execution statement that implements +the C/C semantics. First the op tree in C is executed, +inside a context that traps exceptions. If an exception occurs then the +optree in C is executed, with the trapped exception set into the +lexical variable given by C (which must be an op of type +C). All the optrees are consumed by this function and become part +of the returned op tree. + +The C argument is currently ignored. + +=cut + */ + +OP * +Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock) +{ + OP *catchop; + + PERL_ARGS_ASSERT_NEWTRYCATCHOP; + assert(catchvar->op_type == OP_PADSV); + + PERL_UNUSED_ARG(flags); + + /* The returned optree is shaped as: + * LISTOP leavetrycatch + * LOGOP entertrycatch + * LISTOP poptry + * $tryblock here + * LOGOP catch + * $catchblock here + */ + + if(tryblock->op_type != OP_LINESEQ) + tryblock = op_convert_list(OP_LINESEQ, 0, tryblock); + OpTYPE_set(tryblock, OP_POPTRY); + + /* Manually construct a naked LOGOP. + * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL) + * containing the LOGOP we wanted as its op_first */ + catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock); + OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock); + OpLASTSIB_set(catchblock, catchop); + + /* Inject the catchvar's pad offset into the OP_CATCH targ */ + cLOGOPx(catchop)->op_targ = catchvar->op_targ; + op_free(catchvar); + + /* Build the optree structure */ + return newLISTOPn(OP_ENTERTRYCATCH, 0, + tryblock, + catchop, + NULL); +} + +/* =for apidoc newRANGE Constructs and returns a C op, with subordinate C and @@ -9662,25 +9101,25 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) right->op_next = flop; range->op_targ = - pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0); + 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);; + 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 */ + /* check barewords before they might be optimized away */ if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT) - no_bareword_allowed(left); + no_bareword_allowed(left); if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT) - no_bareword_allowed(right); + no_bareword_allowed(right); flip->op_next = o; if (!flip->op_private || !flop->op_private) - LINKLIST(o); /* blow off optimizer unless constant */ + LINKLIST(o); /* blow off optimizer unless constant */ return o; } @@ -9704,81 +9143,81 @@ unused and should always be 1. OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { + PERL_ARGS_ASSERT_NEWLOOPOP; + OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - block->op_type == OP_NULL; + block->op_type == OP_NULL; PERL_UNUSED_ARG(debuggable); - if (expr) { - if (once && ( - (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) - || ( 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. */ - { - op_free(expr); - return block; /* do {} while 0 does once */ + if (once && ( + (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(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. */ + { + op_free(expr); + 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 = cUNOPx(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 (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); + 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); + ASSUME(listop); } if (listop) - ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); + cLISTOPx(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; + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); + o->op_next = cLOGOPx(cUNOPo->op_first)->op_other; } if (o == listop) - o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ + o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ o->op_flags |= flags; o = op_scope(o); @@ -9812,9 +9251,8 @@ loop body to be enclosed in its own scope. OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, - OP *expr, OP *block, OP *cont, I32 has_my) + OP *expr, OP *block, OP *cont, I32 has_my) { - dVAR; OP *redo; OP *next = NULL; OP *listop; @@ -9824,50 +9262,50 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, PERL_UNUSED_ARG(debuggable); if (expr) { - if (expr->op_type == OP_READLINE + 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) + || 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 = cUNOPx(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; - } - } + expr = newUNOP(OP_DEFINED, 0, expr); + break; + } + } } if (!block) - block = newOP(OP_NULL, 0); + block = newOP(OP_NULL, 0); else if (cont || has_my) { - block = op_scope(block); + block = op_scope(block); } if (cont) { - next = LINKLIST(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); + OP * const unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = op_append_elem(OP_LINESEQ, cont, unstack); } assert(block); @@ -9876,24 +9314,24 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, 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)); + 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) + cLISTOPx(listop)->op_last->op_next = + (o == listop ? redo : LINKLIST(o)); } else - o = listop; + o = listop; if (!loop) { - NewOp(1101,loop,1,LOOP); + NewOp(1101,loop,1,LOOP); OpTYPE_set(loop, OP_ENTERLOOP); - loop->op_private = 0; - loop->op_next = (OP*)loop; + loop->op_private = 0; + loop->op_next = (OP*)loop; } o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o); @@ -9903,9 +9341,9 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, o->op_private |= loopflags; if (next) - loop->op_nextop = next; + loop->op_nextop = next; else - loop->op_nextop = o; + loop->op_nextop = o; o->op_flags |= flags; o->op_private |= (flags >> 8); @@ -9919,7 +9357,7 @@ Constructs, checks, and returns an op tree expressing a C loop (iteration through a list of values). This is a heavyweight loop, with structure that allows exiting the loop by C and suchlike. -C optionally supplies the variable that will be aliased to each +C optionally supplies the variable(s) that will be aliased to each item in turn; if null, it defaults to C<$_>. C supplies the list of values to iterate over. C supplies the main body of the loop, and C optionally supplies a C @@ -9938,7913 +9376,5874 @@ automatically. OP * Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) { - dVAR; LOOP *loop; - OP *wop; + OP *iter; PADOFFSET padoff = 0; + PADOFFSET how_many_more = 0; I32 iterflags = 0; I32 iterpflags = 0; + bool parens = 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 () */ + 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; + /* 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 */ + if (sv->op_flags & OPf_PARENS) { + /* handle degenerate 1-var form of "for my ($x, ...)" */ + sv->op_private |= OPpLVAL_INTRO; + parens = 1; + } + 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 { - sv = newGVOP(OP_GV, 0, PL_defgv); - 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; - - /* upgrade loop from a LISTOP to a LOOPOP; - * keep it in-place if there's space */ - if (loop->op_slabbed - && OpSLOT(loop)->opslot_size - < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P) - { - /* no space; allocate new op */ - LOOP *tmp; - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LISTOP); - assert(loop->op_last->op_sibparent == (OP*)loop); - OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */ - S_op_destroy(aTHX_ (OP*)loop); - loop = tmp; - } - else if (!loop->op_slabbed) - { - /* loop was malloc()ed */ - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); - OpLASTSIB_set(loop->op_last, (OP*)loop); - } - loop->op_targ = padoff; - wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); - return wop; -} - -/* -=for apidoc newLOOPEX - -Constructs, checks, and returns a loop-exiting op (such as C -or C). C is the opcode. C