X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/02b85d3dab092d678cfc958a2dc252405333ed25..8030c9e25386e5b6c76df5c0f8ee9cdd27ae92e8:/op.c diff --git a/op.c b/op.c index 46685dc..666ef26 100644 --- a/op.c +++ b/op.c @@ -207,38 +207,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 +259,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,8 +267,6 @@ S_new_slab(pTHX_ OPSLAB *head, size_t sz) return slab; } -/* 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(OP)) + OPSLOT_HEADER_P) #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE) #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o) @@ -308,7 +319,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 @@ -319,7 +330,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; } @@ -330,25 +341,24 @@ 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 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 && - OPSLOT_SIZE_TO_INDEX(sz) < head_slab->opslab_freed_size) { + 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); + 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) { } @@ -358,52 +368,50 @@ Perl_Slab_Alloc(pTHX_ size_t sz) 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)); - head_slab->opslab_freed[base_index] = 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; + 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 + /* 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)); @@ -426,11 +434,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); } } @@ -444,13 +452,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; } @@ -459,13 +467,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 * @@ -494,8 +495,8 @@ 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); @@ -504,9 +505,7 @@ Perl_Slab_Free(pTHX_ void *op) o->op_type = OP_FREED; 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); } @@ -516,8 +515,8 @@ Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) const bool havepad = !!PL_comppad; PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { - ENTER; - PAD_SAVE_SETNULLPAD(); + ENTER; + PAD_SAVE_SETNULLPAD(); } opslab_free(slab); if (havepad) LEAVE; @@ -543,19 +542,19 @@ Perl_opslab_free(pTHX_ OPSLAB *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); @@ -575,34 +574,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); @@ -651,16 +648,16 @@ 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]; \ + o->op_type = (OPCODE)type; \ + o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END STATIC OP * @@ -669,7 +666,7 @@ 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; } @@ -696,11 +693,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) { @@ -708,7 +703,7 @@ 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 @@ -717,77 +712,94 @@ S_no_bareword_allowed(pTHX_ OP *o) PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; qerror(Perl_mess(aTHX_ - "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", - SVfARG(cSVOPo_sv))); + "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 - ) + (is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0), + PL_parser->in_my_stash, + (is_our + /* $_ is always in main::, even with our */ + ? (PL_curstash && !memEQs(name,len,"$_") + ? PL_curstash + : PL_defstash) + : NULL + ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ if (PL_parser->in_my == KEY_state && CvANON(PL_compcv)) - CvCLONE_on(PL_compcv); + CvCLONE_on(PL_compcv); return off; } /* -=head1 Optree Manipulation Functions +=for apidoc_section $optree_manipulation =for apidoc alloccopstash @@ -809,15 +821,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; @@ -848,7 +860,6 @@ to from any optree. void Perl_op_free(pTHX_ OP *o) { - dVAR; OPCODE type; OP *top_op = o; OP *next_op = o; @@ -928,11 +939,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])); } @@ -1022,7 +1037,6 @@ void Perl_op_clear(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_OP_CLEAR; @@ -1032,12 +1046,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: @@ -1046,17 +1060,17 @@ 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 (cMETHOPx(o)->op_rclass_targ) { + pad_swipe(cMETHOPx(o)->op_rclass_targ, 1); + cMETHOPx(o)->op_rclass_targ = 0; + } #else - SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); - cMETHOPx(o)->op_rclass_sv = NULL; + SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv); + cMETHOPx(o)->op_rclass_sv = NULL; #endif /* FALLTHROUGH */ case OP_METHOD_NAMED: @@ -1072,52 +1086,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 */ @@ -1132,15 +1146,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 @@ -1148,19 +1162,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); @@ -1292,8 +1306,8 @@ Perl_op_clear(pTHX_ OP *o) } if (o->op_targ > 0) { - pad_free(o->op_targ); - o->op_targ = 0; + pad_free(o->op_targ); + o->op_targ = 0; } } @@ -1302,9 +1316,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) ) { + (void)SvIOK_off(*svp); + SvIV_set(*svp, 0); + } + } + } CopFILE_free(cop); if (! specialWARN(cop->cop_warnings)) - PerlMemShared_free(cop->cop_warnings); + PerlMemShared_free(cop->cop_warnings); cophh_free(CopHINTHASH_get(cop)); if (PL_curcop == cop) PL_curcop = NULL; @@ -1318,31 +1350,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; } @@ -1392,12 +1424,11 @@ 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); @@ -1407,9 +1438,6 @@ void Perl_op_refcnt_lock(pTHX) PERL_TSA_ACQUIRE(PL_op_mutex) { -#ifdef USE_ITHREADS - dVAR; -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } @@ -1418,9 +1446,6 @@ void Perl_op_refcnt_unlock(pTHX) PERL_TSA_RELEASE(PL_op_mutex) { -#ifdef USE_ITHREADS - dVAR; -#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } @@ -1434,7 +1459,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 @@ -1631,7 +1656,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); @@ -1654,7 +1678,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. @@ -1666,12 +1690,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); } } @@ -1742,7 +1766,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; } @@ -1757,17 +1781,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); } @@ -1777,19 +1801,19 @@ 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); } } @@ -1803,15 +1827,15 @@ 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"; + *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 = "..."; } @@ -1821,20 +1845,20 @@ S_scalar_slice_warning(pTHX_ const OP *o) { OP *kid; const bool h = o->op_type == OP_HSLICE - || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); + || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); const char lbrack = - h ? '{' : '['; + h ? '{' : '['; const char rbrack = - h ? '}' : ']'; + h ? '}' : ']'; SV *name; SV *keysv = NULL; /* just to silence compiler warnings */ const char *key = NULL; if (!(o->op_private & OPpSLICEWARNING)) - return; + return; if (PL_parser && PL_parser->error_count) - /* This warning can be nonsensical when there is a syntax error. */ - return; + /* This warning can be nonsensical when there is a syntax error. */ + return; kid = cLISTOPo->op_first; kid = OpSIBLING(kid); /* get past pushmark */ @@ -1862,7 +1886,7 @@ S_scalar_slice_warning(pTHX_ const OP *o) case OP_LOCALTIME: case OP_GMTIME: case OP_ENTEREVAL: - return; + return; } /* Don't warn if we have a nulled list either. */ @@ -1872,24 +1896,24 @@ S_scalar_slice_warning(pTHX_ const OP *o) assert(OpSIBLING(kid)); name = S_op_varname(aTHX_ OpSIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ - return; + 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); + 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); + 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); } @@ -2070,7 +2094,6 @@ Perl_scalar(pTHX_ OP *o) OP * Perl_scalarvoid(pTHX_ OP *arg) { - dVAR; OP *kid; SV* sv; OP *o = arg; @@ -2119,11 +2142,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; @@ -2451,8 +2474,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; } @@ -2603,34 +2626,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; } @@ -2640,7 +2669,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; } @@ -2876,7 +2905,6 @@ S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info) STATIC void S_maybe_multiconcat(pTHX_ OP *o) { - 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 */ @@ -2991,7 +3019,7 @@ S_maybe_multiconcat(pTHX_ OP *o) } if (targetop) { - /* Can targetop (the LHS) if it's a padsv, be be optimised + /* Can targetop (the LHS) if it's a padsv, be optimised * away and use OPpTARGET_MY instead? */ if ( (targetop->op_type == OP_PADSV) @@ -3239,7 +3267,7 @@ S_maybe_multiconcat(pTHX_ OP *o) * X .= Y * * otherwise we could be doing something like $x = "foo", which - * if treated as as a concat, would fail to COW. + * if treated as a concat, would fail to COW. */ if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2) return; @@ -3879,16 +3907,16 @@ S_finalize_op(pTHX_ OP* o) && 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); - } + 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; @@ -3945,11 +3973,11 @@ S_finalize_op(pTHX_ OP* o) 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)) + 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; + break; } key_op = (SVOP*)(kid->op_type == OP_CONST @@ -4038,19 +4066,19 @@ S_mark_padname_lvalue(pTHX_ PADNAME *pn) CV *cv = PL_compcv; PadnameLVALUE_on(pn); while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { - cv = CvOUTSIDE(cv); + 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) + if (!cv) break; - assert(CvPADLIST(cv)); - pn = - PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; - assert(PadnameLEN(pn)); - PadnameLVALUE_on(pn); + assert(CvPADLIST(cv)); + pn = + PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; + assert(PadnameLEN(pn)); + PadnameLVALUE_on(pn); } } @@ -4064,7 +4092,7 @@ S_vivifies(const OPCODE type) case OP_AELEMFAST: case OP_KVHSLICE: case OP_HELEM: case OP_AELEM: - return 1; + return 1; } return 0; } @@ -4081,7 +4109,6 @@ S_vivifies(const OPCODE type) static void S_lvref(pTHX_ OP *o, I32 type) { - dVAR; OP *kid; OP * top_op = o; @@ -4228,7 +4255,7 @@ 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; + || type == OP_REFGEN || type == OP_LEAVESUBLV; } @@ -4259,11 +4286,10 @@ op_lvalue(). The flags param has these bits: 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; + return o; while (1) { OP *kid; @@ -4272,9 +4298,9 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) OP *next_kid = NULL; if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ { - goto do_next; + goto do_next; } /* elements of a list might be in void context because the list is @@ -4286,71 +4312,73 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) switch (o->op_type) { case OP_UNDEF: - PL_modcount++; - goto do_next; + if (type == OP_SASSIGN) + goto nomod; + PL_modcount++; + goto do_next; case OP_STUB: - if ((o->op_flags & OPf_PARENS)) - break; - goto nomod; + 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)) { + 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; + 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 (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; @@ -4360,21 +4388,21 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) SVfARG(namesv), PL_op_desc[type]), SvUTF8(namesv)); goto do_next; - } - } - /* FALLTHROUGH */ + } + } + /* 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; + 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: @@ -4395,211 +4423,211 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_I_MODULO: case OP_I_ADD: case OP_I_SUBTRACT: - if (!(o->op_flags & OPf_STACKED)) - goto nomod; - PL_modcount++; - break; + 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; + 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; + 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; + localize = 1; next_kid = OpSIBLING(cUNOPo->op_first); - break; + break; case OP_RV2AV: case OP_RV2HV: - if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { + 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 */ + } + /* FALLTHROUGH */ case OP_RV2GV: - if (scalar_mod_type(o, type)) - goto nomod; - ref(cUNOPo->op_first, o->op_type); - /* FALLTHROUGH */ + 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 */ + 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 */ + /* 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; + break; case OP_KVHSLICE: case OP_KVASLICE: case OP_AKEYS: - if (type == OP_LEAVESUBLV) - o->op_private |= OPpMAYBE_LVSUB; + 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; + 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; + 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 */ + ref(cUNOPo->op_first, o->op_type); + localize = 1; + /* FALLTHROUGH */ case OP_GV: - PL_hints |= HINT_BLOCK_SCOPE; + PL_hints |= HINT_BLOCK_SCOPE; /* FALLTHROUGH */ case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: - PL_modcount++; - break; + PL_modcount++; + break; case OP_AELEMFAST: case OP_AELEMFAST_LEX: - localize = -1; - PL_modcount++; - break; + 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) - { + 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 */ + 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; + 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; + localize = 0; + break; case OP_KEYS: - if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type)) - goto nomod; - goto lvalue_func; + 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 */ + 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)) { + 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; + /* 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; + 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; + 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; + 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; + 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) { + 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 @@ -4629,79 +4657,79 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert( !OpHAS_SIBLING(next_kid) || !OpHAS_SIBLING(OpSIBLING(next_kid))); break; - } - /* FALLTHROUGH */ + } + /* FALLTHROUGH */ case OP_LIST: - localize = 0; - next_kid = cLISTOPo->op_first; - break; + localize = 0; + next_kid = cLISTOPo->op_first; + break; case OP_COREARGS: - goto do_next; + 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; + 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; + 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; + 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; + { + 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; + /* 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; + op_lvalue(cUNOPo->op_first, OP_ENTERSUB); + goto nomod; } /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that @@ -4714,25 +4742,25 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) 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); + 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)); - } + 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; + o->op_flags |= OPf_REF; do_next: while (!next_kid) { @@ -4746,7 +4774,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) I32 ptype = parent->op_type; if ( (ptype == OP_NULL && parent->op_targ != OP_LIST) || ( (ptype == OP_AND || ptype == OP_OR) - && (type != OP_LEAVESUBLV + && (type != OP_LEAVESUBLV && S_vivifies(next_kid->op_type)) ) ) { @@ -4773,9 +4801,9 @@ 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 */ + if (o && o->op_type == OP_RV2GV) + return FALSE; + /* FALLTHROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: @@ -4819,9 +4847,9 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_DORASSIGN: case OP_VEC: case OP_SUBSTR: - return TRUE; + return TRUE; default: - return FALSE; + return FALSE; } } @@ -4833,20 +4861,20 @@ S_is_handle_constructor(const OP *o, I32 numargs) switch (o->op_type) { case OP_PIPE_OP: case OP_SOCKPAIR: - if (numargs == 2) - return TRUE; - /* FALLTHROUGH */ + 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 */ + if (numargs == 1) + return TRUE; + /* FALLTHROUGH */ default: - return FALSE; + return FALSE; } } @@ -4856,7 +4884,7 @@ 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); + ref(kid, type); } return o; } @@ -4877,13 +4905,12 @@ S_refkids(pTHX_ OP *o, I32 type) 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; + return o; while (1) { switch (o->op_type) { @@ -5010,16 +5037,16 @@ S_dup_attrlist(pTHX_ OP *o) * 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)); + 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))); - } + 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; } @@ -5058,20 +5085,20 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) PERL_ARGS_ASSERT_APPLY_ATTRS_MY; if (!attrs) - return; + return; assert(target->op_type == OP_PADSV || - target->op_type == OP_PADHV || - target->op_type == OP_PADAV); + 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 */ + NOOP; /* already in %INC */ else - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs(ATTRSMODULE), NULL); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs(ATTRSMODULE), NULL); /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); @@ -5082,18 +5109,18 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) 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))); + 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))); + 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); @@ -5140,12 +5167,12 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, } Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvs(ATTRSMODULE), + 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))), + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + op_prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(MUTABLE_SV(cv))), attrs))); } @@ -5277,72 +5304,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; } @@ -5358,35 +5385,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 = (LISTOP *)rops; /* for brevity */ + if (rops->op_type == OP_LIST && + lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) + { + OP * const pushmark = lrops->op_first; /* excise pushmark */ op_sibling_splice(rops, NULL, 1, NULL); - op_free(pushmark); - } - o = op_append_list(OP_LIST, o, rops); - } + op_free(pushmark); + } + o = op_append_list(OP_LIST, o, rops); + } } PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -5398,7 +5425,7 @@ Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; if (o) - o->op_flags |= OPf_PARENS; + o->op_flags |= OPf_PARENS; return o; } @@ -5413,53 +5440,53 @@ 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); + S_op_varname(aTHX_ 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 @@ -5474,41 +5501,41 @@ 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)); } OP * -Perl_cmpchain_start(pTHX_ Optype type, OP *left, OP *right) +Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right) { BINOP *bop; OP *op; if (!left) - left = newOP(OP_NULL, 0); + left = newOP(OP_NULL, 0); if (!right) - right = newOP(OP_NULL, 0); + right = newOP(OP_NULL, 0); scalar(left); scalar(right); NewOp(0, bop, 1, BINOP); @@ -5525,37 +5552,37 @@ Perl_cmpchain_start(pTHX_ Optype type, OP *left, OP *right) } OP * -Perl_cmpchain_extend(pTHX_ Optype type, OP *ch, OP *right) +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); + 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; + 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); @@ -5566,50 +5593,51 @@ Perl_cmpchain_extend(pTHX_ Optype type, OP *ch, OP *right) OP * Perl_cmpchain_finish(pTHX_ OP *ch) { + PERL_ARGS_ASSERT_CMPCHAIN_FINISH; if (ch->op_type != OP_NULL) { - Optype 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; + 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); - Optype 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 = fold_constants(op_integerize(op_std_init(cmpop))); - condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) : - cmpop; - if (!nextrightarg) - return condop; - rightarg = nextrightarg; - } + 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; + } } } @@ -5630,29 +5658,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 = ((LISTOP*)o)->op_first; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + op_null(kid); + + /* The following deals with things like 'do {1 for 1}' */ + kid = OpSIBLING(kid); + if (kid && + (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) + op_null(kid); + } + } + else + o = newLISTOP(OP_SCOPE, 0, o, NULL); } return o; } @@ -5661,10 +5688,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; } @@ -5715,81 +5742,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); @@ -5798,7 +5825,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) } /* -=head1 Compile-time scope hooks +=for apidoc_section $scope =for apidoc blockhook_register @@ -5824,35 +5851,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 @@ -5879,33 +5906,33 @@ 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) { + dSP; + PUSHMARK(SP); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); + PUTBACK; + call_sv(MUTABLE_SV(cv), G_DISCARD); + } + } } } @@ -5918,53 +5945,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; @@ -5976,9 +6003,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; } @@ -5991,9 +6026,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; } @@ -6008,13 +6043,12 @@ 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; } @@ -6031,7 +6065,7 @@ S_fold_constants_eval(pTHX) { JMPENV_PUSH(ret); if (ret == 0) { - CALLRUNOPS(aTHX); + CALLRUNOPS(aTHX); } JMPENV_POP; @@ -6042,7 +6076,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; @@ -6059,7 +6092,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: @@ -6068,8 +6101,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: @@ -6078,44 +6111,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) { @@ -6135,8 +6168,8 @@ S_fold_constants(pTHX_ OP *const o) default: /* No other op types are considered foldable */ - goto nope; - } + goto nope; + } } curop = LINKLIST(o); @@ -6159,35 +6192,35 @@ 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 (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; @@ -6202,7 +6235,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 @@ -6212,10 +6245,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; @@ -6232,7 +6265,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; @@ -6248,17 +6280,17 @@ 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; + o->op_type = OP_NULL; S_prune_chain_head(&curop); PL_op = curop; @@ -6277,30 +6309,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; @@ -6315,7 +6347,7 @@ 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 */ @@ -6329,18 +6361,18 @@ S_gen_constant_list(pTHX_ OP *o) op_free(curop); if (AvFILLp(av) != -1) - for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) - { - SvPADTMP_on(*svp); - SvREADONLY_on(*svp); - } + for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) + { + SvPADTMP_on(*svp); + SvREADONLY_on(*svp); + } LINKLIST(o); list(o); return; } /* -=head1 Optree Manipulation Functions +=for apidoc_section $optree_manipulation */ /* List constructors */ @@ -6362,15 +6394,15 @@ 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); @@ -6395,16 +6427,16 @@ 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; @@ -6433,22 +6465,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); @@ -6471,24 +6503,23 @@ 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 (!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) @@ -6500,11 +6531,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))); } @@ -6513,7 +6544,7 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) /* -=head1 Optree construction +=for apidoc_section $optree_construction =for apidoc newNULLLIST @@ -6552,7 +6583,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); } @@ -6583,7 +6614,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 @@ -6591,29 +6621,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); @@ -6635,18 +6665,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); @@ -6655,9 +6684,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); } @@ -6680,27 +6709,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 = force_list(first, TRUE); NewOp(1101, unop, 1, UNOP); OpTYPE_set(unop, type); @@ -6713,7 +6742,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))); } @@ -6730,7 +6759,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 @@ -6769,7 +6797,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 @@ -6777,7 +6804,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 = force_list(dynamic_meth, TRUE); methop->op_flags = (U8)(flags | OPf_KIDS); methop->op_u.op_first = dynamic_meth; methop->op_private = (U8)(1 | (flags >> 8)); @@ -6845,26 +6872,25 @@ 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); + || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); if (!first) - first = newOP(OP_NULL, 0); + first = newOP(OP_NULL, 0); OpTYPE_set(binop, type); binop->op_first = first; binop->op_flags = (U8)(flags | OPf_KIDS); if (!last) { - last = first; - binop->op_private = (U8)(1 | (flags >> 8)); + 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); } @@ -6877,7 +6903,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) 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))); } @@ -6900,10 +6926,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, " "); } @@ -6966,18 +6992,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 @@ -7014,9 +7041,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 @@ -7024,14 +7051,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; @@ -7058,30 +7085,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; @@ -7209,6 +7235,21 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) 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++) { @@ -7342,7 +7383,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++; } @@ -7353,7 +7394,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 @@ -7361,7 +7402,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; @@ -7393,16 +7436,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; @@ -7471,7 +7516,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); @@ -7501,6 +7551,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 @@ -7522,21 +7579,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; @@ -7569,8 +7636,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 @@ -7590,7 +7657,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 @@ -7889,7 +7956,7 @@ 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()); av_push(invmap, t_invlist); /* 2nd is the mapping */ @@ -8033,9 +8100,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); @@ -8058,29 +8125,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_ @@ -8099,23 +8165,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 @@ -8129,11 +8195,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); } } @@ -8203,7 +8269,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); @@ -8279,8 +8345,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) 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 */ @@ -8288,30 +8354,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 @@ -8320,212 +8386,212 @@ 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); + ((PMOP*)qr)->op_code_list = expr; + + /* handle the implicit sub{} wrapped round the qr/(?{..})/ */ + SvREFCNT_inc_simple_void(PL_compcv); + cv = newATTRSUB(floor, 0, NULL, NULL, qr); + ReANY(re)->qr_anoncv = cv; + + /* attach the anon CV to the pad so that + * pad_fixup_inner_anons() can find it */ + (void)pad_add_anon(cv, o->op_type); + SvREFCNT_inc_simple_void(cv); + } + else { + pm->op_code_list = expr; + } + } } else { - /* runtime pattern: build chain of regcomp etc ops */ - bool reglist; - PADOFFSET cv_targ = 0; - - reglist = isreg && expr->op_type == OP_LIST; - if (reglist) - op_null(expr); - - if (has_code) { - pm->op_code_list = expr; - /* don't free op_code_list; its ops are embedded elsewhere too */ - pm->op_pmflags |= PMf_CODELIST_PRIVATE; - } + /* 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 + * srefgen + * 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, 0, + MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr))); + cv_targ = expr->op_targ; + expr = newUNOP(OP_REFGEN, 0, expr); - /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ - if (PL_hints & HINT_RE_EVAL) - S_set_haseval(aTHX); + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), TRUE)); + } - /* 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; + ((UNOP*)expr)->op_first->op_next = (OP*)rcop; + } + else { + rcop->op_next = LINKLIST(expr); + expr->op_next = (OP*)rcop; + } - op_prepend_elem(o->op_type, scalar((OP*)rcop), o); + 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; @@ -8545,15 +8611,14 @@ takes ownership of one reference to it. OP * Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { - dVAR; SVOP *svop; PERL_ARGS_ASSERT_NEWSVOP; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP - || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP - || type == OP_CUSTOM); + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || type == OP_CUSTOM); NewOp(1101, svop, 1, SVOP); OpTYPE_set(svop, type); @@ -8562,9 +8627,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); } @@ -8579,7 +8644,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 @@ -8601,29 +8666,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); } @@ -8669,15 +8733,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_RUNCV || type == OP_CUSTOM + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); OpTYPE_set(pvop, type); @@ -8686,9 +8749,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); } @@ -8734,98 +8797,101 @@ 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; + SV * const vesv = ((SVOP*)version)->op_sv; - if (!arg && !SvNIOKp(vesv)) { - arg = version; - } - else { - OP *pack; - SV *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"); + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) + Perl_croak(aTHX_ "Version number must be a constant number"); - /* Make copy of idop so we don't free it twice */ - pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); + /* Make copy of idop so we don't free it twice */ + pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); - /* Fake up a method call to VERSION */ - meth = newSVpvs_share("VERSION"); - veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, pack, version), - newMETHOP_named(OP_METHOD_NAMED, 0, meth))); - } + /* Fake up a method call to VERSION */ + meth = newSVpvs_share("VERSION"); + veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, version), + newMETHOP_named(OP_METHOD_NAMED, 0, meth))); + } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { - imop = arg; /* no import on explicit () */ + 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; + imop = NULL; /* use 5.0; */ + if (aver) + use_version = ((SVOP*)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(((SVOP*)idop)->op_sv)); - /* Fake up a method call to import/unimport */ - meth = aver - ? newSVpvs_share("import") : newSVpvs_share("unimport"); - imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - op_append_elem(OP_LIST, - op_prepend_elem(OP_LIST, pack, arg), - newMETHOP_named(OP_METHOD_NAMED, 0, meth) - )); + /* Fake up a method call to import/unimport */ + meth = aver + ? newSVpvs_share("import") : newSVpvs_share("unimport"); + imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, + op_append_elem(OP_LIST, + op_prepend_elem(OP_LIST, pack, arg), + newMETHOP_named(OP_METHOD_NAMED, 0, meth) + )); } /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, - newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")), - NULL, - NULL, - op_append_elem(OP_LINESEQ, - op_append_elem(OP_LINESEQ, - newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)), - newSTATEOP(0, NULL, veop)), - newSTATEOP(0, NULL, imop) )); + 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); + + /* 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; + + if (vcmp(use_version, sv_2mortal(upg_version(newSVpvs("5.035000"), FALSE))) >= 0) + free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); + } + /* otherwise they are off */ + else { + if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS)) + PL_hints &= ~HINT_STRICT_REFS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS)) + PL_hints &= ~HINT_STRICT_SUBS; + if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS)) + PL_hints &= ~HINT_STRICT_VARS; + } } /* The "did you use incorrect case?" warning used to be here. @@ -8851,7 +8917,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) } /* -=head1 Embedding Functions +=for apidoc_section $embedding =for apidoc load_module @@ -8884,6 +8950,14 @@ than C. =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. + +=for apidoc load_module_nocontext +Like C> but does not take a thread context (C) parameter, +so is used in situations where the caller doesn't already have the thread +context. + =cut */ void @@ -8898,7 +8972,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, ...) { @@ -8940,24 +9014,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); @@ -8968,9 +9042,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 * @@ -8982,16 +9056,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 @@ -9010,8 +9084,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(force_list(subscript, TRUE)), + list(force_list(listval, TRUE))); } #define ASSIGN_SCALAR 0 @@ -9032,24 +9106,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) { @@ -9057,29 +9131,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; } @@ -9087,15 +9161,14 @@ 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; @@ -9143,82 +9216,82 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) I32 assign_type; if (optype) { - if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == 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)); + } + else { + 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(force_list(left, TRUE)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, TRUE)), 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) && (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) @@ -9226,7 +9299,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)) @@ -9308,24 +9381,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; } @@ -9351,7 +9424,6 @@ 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; @@ -9378,13 +9450,13 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop))); if (label) { - Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8); + 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) { @@ -9394,8 +9466,8 @@ 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? */ @@ -9405,19 +9477,19 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) 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); } @@ -9456,43 +9528,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; @@ -9502,7 +9574,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; @@ -9524,138 +9595,138 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 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. + /* 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. + 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". + /* 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. + 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; + 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); /* 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(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)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 = ((UNOP*)first)->op_first; + const OP * const k2 = OpSIBLING(k1); + OPCODE warnop = 0; + switch (first->op_type) + { + case OP_NULL: + if (k2 && k2->op_type == OP_READLINE + && (k2->op_flags & OPf_STACKED) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + { + warnop = k2->op_type; + } + break; + + case OP_SASSIGN: + if (k1->op_type == OP_READDIR + || k1->op_type == OP_GLOB + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH || k1->op_type == OP_AEACH) - { - warnop = ((k1->op_type == OP_NULL) - ? (OPCODE)k1->op_targ : k1->op_type); - } - break; - } - if (warnop) { - const line_t oldline = CopLINE(PL_curcop); + { + 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 */ @@ -9690,8 +9761,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; @@ -9714,7 +9785,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; @@ -9723,30 +9793,30 @@ 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 ((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(((SVOP*)cstop)->op_sv); + OP *live = left ? trueop : falseop; + OP *const dead = left ? falseop : trueop; if (cstop->op_private & OPpCONST_BARE && - cstop->op_private & OPpCONST_STRICT) { - no_bareword_allowed(cstop); - } + 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; @@ -9754,7 +9824,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); @@ -9773,6 +9843,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 *o, *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 */ + o = newLISTOP(OP_LIST, 0, tryblock, catchop); + o = op_convert_list(OP_ENTERTRYCATCH, 0, o); + + return o; +} + +/* =for apidoc newRANGE Constructs and returns a C op, with subordinate C and @@ -9816,10 +9943,10 @@ 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)); @@ -9828,13 +9955,13 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) /* check barewords before they might be optimized aways */ 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; } @@ -9861,78 +9988,78 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - block->op_type == OP_NULL; + 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. */ + 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 (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) + 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; - } - } + 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); + ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) { - assert(cUNOPo->op_first->op_type == OP_AND - || cUNOPo->op_first->op_type == OP_OR); - o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); + o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; } if (o == listop) - o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ + o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ o->op_flags |= flags; o = op_scope(o); @@ -9966,9 +10093,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; @@ -9978,50 +10104,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 = ((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; - } - } + 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); @@ -10030,24 +10156,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) + ((LISTOP*)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); @@ -10057,9 +10183,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); @@ -10073,7 +10199,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 @@ -10092,90 +10218,147 @@ 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; 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 */ + 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; - } + sv = NULL; + PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); + } + else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN) + NOOP; + else if (sv->op_type == OP_LIST) { + LISTOP *list = (LISTOP *) sv; + OP *pushmark = list->op_first; + OP *first_padsv; + UNOP *padsv; + PADOFFSET i; + + iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */ + + if (!pushmark || pushmark->op_type != OP_PUSHMARK) { + Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark", + pushmark ? PL_op_desc[pushmark->op_type] : "NULL"); + } + first_padsv = OpSIBLING(pushmark); + if (!first_padsv || first_padsv->op_type != OP_PADSV) { + Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv", + first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL"); + } + padoff = first_padsv->op_targ; + + /* There should be at least one more PADSV to find, and the ops + should have consecutive values in targ: */ + padsv = (UNOP *) OpSIBLING(first_padsv); + do { + if (!padsv || padsv->op_type != OP_PADSV) { + Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv", + padsv ? PL_op_desc[padsv->op_type] : "NULL", + how_many_more); + } + ++how_many_more; + if (padsv->op_targ != padoff + how_many_more) { + Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd", + how_many_more, padsv->op_targ, padoff + how_many_more); + } + + padsv = (UNOP *) OpSIBLING(padsv); + } while (padsv); + + /* OK, this optree has the shape that we expected. So now *we* + "claim" the Pad slots: */ + first_padsv->op_targ = 0; + PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX); + + i = padoff; + + padsv = (UNOP *) OpSIBLING(first_padsv); + do { + ++i; + padsv->op_targ = 0; + PAD_COMPNAME_GEN_set(i, PERL_INT_MAX); + + padsv = (UNOP *) OpSIBLING(padsv); + } while (padsv); + + op_free(sv); + sv = NULL; + } + 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; + 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; + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), TRUE), 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; + /* 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; + 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_free(expr); + expr = (OP*)(listop); op_null(expr); - iterflags |= OPf_STACKED; + iterflags |= OPf_STACKED; } else { - expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); + expr = op_lvalue(force_list(expr, TRUE), OP_GREPSTART); } loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags, @@ -10190,26 +10373,27 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) * keep it in-place if there's space */ if (loop->op_slabbed && OpSLOT(loop)->opslot_size - < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P) + < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER)) { /* no space; allocate new op */ - LOOP *tmp; - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LISTOP); + 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; + S_op_destroy(aTHX_ (OP*)loop); + loop = tmp; } else if (!loop->op_slabbed) { /* loop was malloc()ed */ - loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); + 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; + iter = newOP(OP_ITER, 0); + iter->op_targ = how_many_more; + return newWHILEOP(flags, 1, loop, iter, block, cont, 0); } /* @@ -10231,37 +10415,37 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP - || type == OP_CUSTOM); + || type == OP_CUSTOM); if (type != OP_GOTO) { - /* "last()" means "last" */ - if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { - o = newOP(type, OPf_SPECIAL); - } + /* "last()" means "last" */ + if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) { + o = newOP(type, OPf_SPECIAL); + } } else { - /* Check whether it's going to be a goto &function */ - if (label->op_type == OP_ENTERSUB - && !(label->op_flags & OPf_STACKED)) - label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); + /* Check whether it's going to be a goto &function */ + if (label->op_type == OP_ENTERSUB + && !(label->op_flags & OPf_STACKED)) + label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN)); } /* Check for a constant argument */ if (label->op_type == OP_CONST) { - SV * const sv = ((SVOP *)label)->op_sv; - STRLEN l; - const char *s = SvPV_const(sv,l); - if (l == strlen(s)) { - o = newPVOP(type, - SvUTF8(((SVOP*)label)->op_sv), - savesharedpv( - SvPV_nolen_const(((SVOP*)label)->op_sv))); - } + SV * const sv = ((SVOP *)label)->op_sv; + STRLEN l; + const char *s = SvPV_const(sv,l); + if (l == strlen(s)) { + o = newPVOP(type, + SvUTF8(((SVOP*)label)->op_sv), + savesharedpv( + SvPV_nolen_const(((SVOP*)label)->op_sv))); + } } /* If we have already created an op, we do not need the label. */ if (o) - op_free(label); + op_free(label); else o = newUNOP(type, OPf_STACKED, label); PL_hints |= HINT_BLOCK_SCOPE; @@ -10280,7 +10464,7 @@ S_ref_array_or_hash(pTHX_ OP *cond) || cond->op_type == OP_RV2HV || cond->op_type == OP_PADHV)) - return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); + return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN)); else if(cond && (cond->op_type == OP_ASLICE @@ -10288,16 +10472,16 @@ S_ref_array_or_hash(pTHX_ OP *cond) || cond->op_type == OP_HSLICE || cond->op_type == OP_KVHSLICE)) { - /* anonlist now needs a list from this op, was previously used in - * scalar context */ - cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); - cond->op_flags |= OPf_WANT_LIST; + /* anonlist now needs a list from this op, was previously used in + * scalar context */ + cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF); + cond->op_flags |= OPf_WANT_LIST; - return newANONLIST(op_lvalue(cond, OP_ANONLIST)); + return newANONLIST(op_lvalue(cond, OP_ANONLIST)); } else - return cond; + return cond; } /* These construct the optree fragments representing given() @@ -10312,10 +10496,9 @@ S_ref_array_or_hash(pTHX_ OP *cond) STATIC OP * S_newGIVWHENOP(pTHX_ OP *cond, OP *block, - I32 enter_opcode, I32 leave_opcode, - PADOFFSET entertarg) + I32 enter_opcode, I32 leave_opcode, + PADOFFSET entertarg) { - dVAR; LOGOP *enterop; OP *o; @@ -10332,20 +10515,20 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, /* prepend cond if we have one */ op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); - o->op_next = LINKLIST(cond); - cond->op_next = (OP *) enterop; + o->op_next = LINKLIST(cond); + cond->op_next = (OP *) enterop; } else { - /* This is a default {} block */ - enterop->op_flags |= OPf_SPECIAL; - o ->op_flags |= OPf_SPECIAL; + /* This is a default {} block */ + enterop->op_flags |= OPf_SPECIAL; + o ->op_flags |= OPf_SPECIAL; - o->op_next = (OP *) enterop; + o->op_next = (OP *) enterop; } CHECKOP(enter_opcode, enterop); /* Currently does nothing, since - entergiven and enterwhen both - use ck_null() */ + entergiven and enterwhen both + use ck_null() */ enterop->op_next = LINKLIST(block); block->op_next = enterop->op_other = o; @@ -10373,74 +10556,74 @@ S_looks_like_bool(pTHX_ const OP *o) PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { - case OP_OR: - case OP_DOR: - return looks_like_bool(cLOGOPo->op_first); + case OP_OR: + case OP_DOR: + return looks_like_bool(cLOGOPo->op_first); - case OP_AND: + case OP_AND: { OP* sibl = OpSIBLING(cLOGOPo->op_first); ASSUME(sibl); - return ( - looks_like_bool(cLOGOPo->op_first) - && looks_like_bool(sibl)); + return ( + looks_like_bool(cLOGOPo->op_first) + && looks_like_bool(sibl)); } - case OP_NULL: - case OP_SCALAR: - return ( - o->op_flags & OPf_KIDS - && looks_like_bool(cUNOPo->op_first)); + case OP_NULL: + case OP_SCALAR: + return ( + o->op_flags & OPf_KIDS + && looks_like_bool(cUNOPo->op_first)); - case OP_ENTERSUB: + case OP_ENTERSUB: - case OP_NOT: case OP_XOR: + case OP_NOT: case OP_XOR: - case OP_EQ: case OP_NE: case OP_LT: - case OP_GT: case OP_LE: case OP_GE: + case OP_EQ: case OP_NE: case OP_LT: + case OP_GT: case OP_LE: case OP_GE: - case OP_I_EQ: case OP_I_NE: case OP_I_LT: - case OP_I_GT: case OP_I_LE: case OP_I_GE: + case OP_I_EQ: case OP_I_NE: case OP_I_LT: + case OP_I_GT: case OP_I_LE: case OP_I_GE: - case OP_SEQ: case OP_SNE: case OP_SLT: - case OP_SGT: case OP_SLE: case OP_SGE: + case OP_SEQ: case OP_SNE: case OP_SLT: + case OP_SGT: case OP_SLE: case OP_SGE: - case OP_SMARTMATCH: + case OP_SMARTMATCH: - case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: - case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: - case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: - case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: - case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: - case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: - case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: - case OP_FTTEXT: case OP_FTBINARY: + case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC: + case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC: + case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED: + case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR: + case OP_FTBLK: case OP_FTFILE: case OP_FTDIR: + case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID: + case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY: + case OP_FTTEXT: case OP_FTBINARY: - case OP_DEFINED: case OP_EXISTS: - case OP_MATCH: case OP_EOF: + case OP_DEFINED: case OP_EXISTS: + case OP_MATCH: case OP_EOF: - case OP_FLOP: + case OP_FLOP: - return TRUE; + return TRUE; - case OP_INDEX: - case OP_RINDEX: + case OP_INDEX: + case OP_RINDEX: /* optimised-away (index() != -1) or similar comparison */ if (o->op_private & OPpTRUEBOOL) return TRUE; return FALSE; - case OP_CONST: - /* Detect comparisons that have been optimized away */ - if (cSVOPo->op_sv == &PL_sv_yes - || cSVOPo->op_sv == &PL_sv_no) + case OP_CONST: + /* Detect comparisons that have been optimized away */ + if (cSVOPo->op_sv == &PL_sv_yes + || cSVOPo->op_sv == &PL_sv_no) - return TRUE; - else - return FALSE; - /* FALLTHROUGH */ - default: - return FALSE; + return TRUE; + else + return FALSE; + /* FALLTHROUGH */ + default: + return FALSE; } } @@ -10465,10 +10648,10 @@ Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) assert(!defsv_off); return newGIVWHENOP( - ref_array_or_hash(cond), - block, - OP_ENTERGIVEN, OP_LEAVEGIVEN, - 0); + ref_array_or_hash(cond), + block, + OP_ENTERGIVEN, OP_LEAVEGIVEN, + 0); } /* @@ -10493,91 +10676,156 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) PERL_ARGS_ASSERT_NEWWHENOP; if (cond_llb) - cond_op = cond; + cond_op = cond; else { - cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, - newDEFSVOP(), - scalar(ref_array_or_hash(cond))); + cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL, + newDEFSVOP(), + scalar(ref_array_or_hash(cond))); } return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* +=for apidoc newDEFEROP + +Constructs and returns a deferred-block statement that implements the +C semantics. The C optree is consumed by this function and +becomes part of the returned optree. + +The C argument carries additional flags to set on the returned op, +including the C field. + +=cut + */ + +OP * +Perl_newDEFEROP(pTHX_ I32 flags, OP *block) +{ + OP *o, *start, *blockfirst; + + PERL_ARGS_ASSERT_NEWDEFEROP; + + start = LINKLIST(block); + + /* Hide the block inside an OP_NULL with no exection */ + block = newUNOP(OP_NULL, 0, block); + block->op_next = block; + + o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start); + o->op_flags |= OPf_WANT_VOID | (U8)(flags); + o->op_private = (U8)(flags >> 8); + + /* Terminate the block */ + blockfirst = cUNOPx(block)->op_first; + assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE); + blockfirst->op_next = NULL; + + return o; +} + +/* +=for apidoc op_wrap_finally + +Wraps the given C optree fragment in its own scoped block, arranging +for the C optree fragment to be invoked when leaving that block for +any reason. Both optree fragments are consumed and the combined result is +returned. + +=cut +*/ + +OP * +Perl_op_wrap_finally(pTHX_ OP *block, OP *finally) +{ + PERL_ARGS_ASSERT_OP_WRAP_FINALLY; + + /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can + * just splice the DEFEROP in at the top, for efficiency. + */ + + OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block); + o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); + OpTYPE_set(o, OP_LEAVE); + + return o; +} + /* must not conflict with SVf_UTF8 */ #define CV_CKPROTO_CURSTASH 0x1 void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, - const STRLEN len, const U32 flags) + const STRLEN len, const U32 flags) { SV *name = NULL, *msg; const char * cvp = SvROK(cv) - ? SvTYPE(SvRV_const(cv)) == SVt_PVCV - ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) - : "" - : CvPROTO(cv); + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; if (p == NULL && cvp == NULL) - return; + return; if (!ckWARN_d(WARN_PROTOTYPE)) - return; + return; if (p && cvp) { - p = S_strip_spaces(aTHX_ p, &plen); - cvp = S_strip_spaces(aTHX_ cvp, &clen); - if ((flags & SVf_UTF8) == SvUTF8(cv)) { - if (plen == clen && memEQ(cvp, p, plen)) - return; - } else { - if (flags & SVf_UTF8) { - if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) - return; + p = S_strip_spaces(aTHX_ p, &plen); + cvp = S_strip_spaces(aTHX_ cvp, &clen); + if ((flags & SVf_UTF8) == SvUTF8(cv)) { + if (plen == clen && memEQ(cvp, p, plen)) + return; + } else { + if (flags & SVf_UTF8) { + if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0) + return; + } + else { + if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) + return; } - else { - if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0) - return; - } - } + } } msg = sv_newmortal(); if (gv) { - if (isGV(gv)) - gv_efullname3(name = sv_newmortal(), gv, NULL); - else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') - name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); - else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { - name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); - sv_catpvs(name, "::"); - if (SvROK(gv)) { - assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); - assert (CvNAMED(SvRV_const(gv))); - sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); - } - else sv_catsv(name, (SV *)gv); - } - else name = (SV *)gv; + if (isGV(gv)) + gv_efullname3(name = sv_newmortal(), gv, NULL); + else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') + name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } + else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); + Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); if (cvp) - Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", - UTF8fARG(SvUTF8(cv),clen,cvp) - ); + Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", + UTF8fARG(SvUTF8(cv),clen,cvp) + ); else - sv_catpvs(msg, ": none"); + sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) - Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); + Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); else - sv_catpvs(msg, "none"); + sv_catpvs(msg, "none"); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg)); } @@ -10586,7 +10834,7 @@ static void const_av_xsub(pTHX_ CV* cv); /* -=head1 Optree Manipulation Functions +=for apidoc_section $optree_manipulation =for apidoc cv_const_sv @@ -10603,9 +10851,9 @@ Perl_cv_const_sv(const CV *const cv) { SV *sv; if (!cv) - return NULL; + return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) - return NULL; + return NULL; sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; if (sv && SvTYPE(sv) == SVt_PVAV) return NULL; return sv; @@ -10615,7 +10863,7 @@ SV * Perl_cv_const_sv_or_av(const CV * const cv) { if (!cv) - return NULL; + return NULL; if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; @@ -10645,87 +10893,87 @@ S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex) assert(cv); for (; o; o = o->op_next) { - const OPCODE type = o->op_type; - - if (type == OP_NEXTSTATE || type == OP_LINESEQ - || type == OP_NULL - || type == OP_PUSHMARK) - continue; - if (type == OP_DBSTATE) - continue; - if (type == OP_LEAVESUB) - break; - if (sv) - return NULL; - if (type == OP_CONST && cSVOPo->op_sv) - sv = cSVOPo->op_sv; - else if (type == OP_UNDEF && !o->op_private) { - sv = newSV(0); - SAVEFREESV(sv); - } - else if (allow_lex && type == OP_PADSV) { - if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) - { - sv = &PL_sv_undef; /* an arbitrary non-null value */ - padsv = TRUE; - } - else - return NULL; - } - else { - return NULL; - } + const OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_LINESEQ + || type == OP_NULL + || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + if (type == OP_LEAVESUB) + break; + if (sv) + return NULL; + if (type == OP_CONST && cSVOPo->op_sv) + sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } + else if (allow_lex && type == OP_PADSV) { + if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER) + { + sv = &PL_sv_undef; /* an arbitrary non-null value */ + padsv = TRUE; + } + else + return NULL; + } + else { + return NULL; + } } if (padsv) { - CvCONST_on(cv); - return NULL; + CvCONST_on(cv); + return NULL; } return sv; } static void S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, - PADNAME * const name, SV ** const const_svp) + PADNAME * const name, SV ** const const_svp) { assert (cv); assert (o || name); assert (const_svp); if (!block) { - if (CvFLAGS(PL_compcv)) { - /* might have had built-in attrs applied */ - const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); - if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl - && ckWARN(WARN_MISC)) - { - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); - SvREFCNT_inc_simple_void_NN(PL_compcv); - } - CvFLAGS(cv) |= - (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS - & ~(CVf_LVALUE * pureperl)); - } - return; + if (CvFLAGS(PL_compcv)) { + /* might have had built-in attrs applied */ + const bool pureperl = !CvISXSUB(cv) && CvROOT(cv); + if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl + && ckWARN(WARN_MISC)) + { + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined"); + SvREFCNT_inc_simple_void_NN(PL_compcv); + } + CvFLAGS(cv) |= + (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS + & ~(CVf_LVALUE * pureperl)); + } + return; } /* redundant check for speed: */ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - SV *namesv = o - ? cSVOPo->op_sv - : sv_2mortal(newSVpvn_utf8( - PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) - )); - if (PL_parser && PL_parser->copline != NOLINE) + const line_t oldline = CopLINE(PL_curcop); + SV *namesv = o + ? cSVOPo->op_sv + : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1, + (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP + ); + if (PL_parser && PL_parser->copline != NOLINE) /* This ensures that warnings are reported at the first line of a redefinition, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - report_redefined_cv(namesv, cv, const_svp); - SvREFCNT_inc_simple_void_NN(PL_compcv); - CopLINE_set(PL_curcop, oldline); + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + report_redefined_cv(namesv, cv, const_svp); + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); } SAVEFREESV(cv); return; @@ -10762,31 +11010,31 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) need to look in CvOUTSIDE and find the pad belonging to the enclos- ing sub. And then we need to dig deeper if this is a lexical from outside, as in: - my sub foo; sub { sub foo { } } + my sub foo; sub { sub foo { } } */ redo: name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax]; if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) { - pax = PARENT_PAD_INDEX(name); - outcv = CvOUTSIDE(outcv); - assert(outcv); - goto redo; + pax = PARENT_PAD_INDEX(name); + outcv = CvOUTSIDE(outcv); + assert(outcv); + goto redo; } svspot = - &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) - [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; + &PadARRAY(PadlistARRAY(CvPADLIST(outcv)) + [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax]; spot = (CV **)svspot; if (!(PL_parser && PL_parser->error_count)) move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0); if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } else - ps = NULL; + ps = NULL; if (proto) SAVEFREEOP(proto); @@ -10794,54 +11042,53 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREEOP(attrs); if (PL_parser && PL_parser->error_count) { - op_free(block); - SvREFCNT_dec(PL_compcv); - PL_compcv = 0; - goto done; + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = 0; + goto done; } if (CvDEPTH(outcv) && CvCLONE(compcv)) { - cv = *spot; - svspot = (SV **)(spot = &clonee); + cv = *spot; + svspot = (SV **)(spot = &clonee); } else if (PadnameIsSTATE(name) || CvDEPTH(outcv)) - cv = *spot; + cv = *spot; else { - assert (SvTYPE(*spot) == SVt_PVCV); - if (CvNAMED(*spot)) - hek = CvNAME_HEK(*spot); - else { - dVAR; - U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); - CvNAME_HEK_set(*spot, hek = - share_hek( - PadnamePV(name)+1, - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), - hash - ) - ); - CvLEXICAL_on(*spot); - } - cv = PadnamePROTOCV(name); - svspot = (SV **)(spot = &PadnamePROTOCV(name)); + assert (SvTYPE(*spot) == SVt_PVCV); + if (CvNAMED(*spot)) + hek = CvNAME_HEK(*spot); + else { + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + CvNAME_HEK_set(*spot, hek = + share_hek( + PadnamePV(name)+1, + (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + hash + ) + ); + CvLEXICAL_on(*spot); + } + cv = PadnamePROTOCV(name); + svspot = (SV **)(spot = &PadnamePROTOCV(name)); } if (block) { - /* This makes sub {}; work as expected. */ - if (block->op_type == OP_STUB) { - const line_t l = PL_parser->copline; - op_free(block); - block = newSTATEOP(0, NULL, 0); - PL_parser->copline = l; - } - block = CvLVALUE(compcv) - || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) - ? newUNOP(OP_LEAVESUBLV, 0, - op_lvalue(scalarseq(block), OP_LEAVESUBLV)) - : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - start = LINKLIST(block); - block->op_next = 0; + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(voidnonfinal(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block)); + start = LINKLIST(block); + block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(compcv)) const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE); else @@ -10860,49 +11107,49 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len, ps_utf8); - /* already defined? */ - if (exists) { - S_already_defined(aTHX_ cv, block, NULL, name, &const_sv); + /* already defined? */ + if (exists) { + S_already_defined(aTHX_ cv, block, NULL, name, &const_sv); if (block) - cv = NULL; - else { - if (attrs) + cv = NULL; + else { + if (attrs) goto attrs; - /* just a "sub foo;" when &foo is already defined */ - SAVEFREESV(compcv); - goto done; - } - } - else if (CvDEPTH(outcv) && CvCLONE(compcv)) { - cv = NULL; - reusable = TRUE; - } - } - + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(compcv); + goto done; + } + } + else if (CvDEPTH(outcv) && CvCLONE(compcv)) { + cv = NULL; + reusable = TRUE; + } + } + if (const_sv) { - SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) |= SVs_PADTMP; - if (cv) { - assert(!CvROOT(cv) && !CvCONST(cv)); - cv_forget_slab(cv); - } - else { - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); - *spot = cv; - } + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); + } + else { + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); + *spot = cv; + } SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ - CvXSUBANY(cv).any_ptr = const_sv; - CvXSUB(cv) = const_sv_xsub; - CvCONST_on(cv); - CvISXSUB_on(cv); - PoisonPADLIST(cv); - CvFLAGS(cv) |= CvMETHOD(compcv); - op_free(block); - SvREFCNT_dec(compcv); - PL_compcv = NULL; - goto setname; + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(compcv); + op_free(block); + SvREFCNT_dec(compcv); + PL_compcv = NULL; + goto setname; } /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to @@ -10912,73 +11159,72 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) the package sub. So check PadnameOUTER(name) too. */ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { - assert(!CvWEAKOUTSIDE(compcv)); - SvREFCNT_dec(CvOUTSIDE(compcv)); - CvWEAKOUTSIDE_on(compcv); + assert(!CvWEAKOUTSIDE(compcv)); + SvREFCNT_dec(CvOUTSIDE(compcv)); + CvWEAKOUTSIDE_on(compcv); } /* XXX else do we have a circular reference? */ if (cv) { /* must reuse cv in case stub is referenced elsewhere */ - /* transfer PL_compcv to cv */ - if (block) { + /* transfer PL_compcv to cv */ + if (block) { bool free_file = CvFILE(cv) && CvDYNFILE(cv); - cv_flags_t preserved_flags = - CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); - PADLIST *const temp_padl = CvPADLIST(cv); - CV *const temp_cv = CvOUTSIDE(cv); - const cv_flags_t other_flags = - CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); - OP * const cvstart = CvSTART(cv); - - SvPOK_off(cv); - CvFLAGS(cv) = - CvFLAGS(compcv) | preserved_flags; - CvOUTSIDE(cv) = CvOUTSIDE(compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); - CvPADLIST_set(cv, CvPADLIST(compcv)); - CvOUTSIDE(compcv) = temp_cv; - CvPADLIST_set(compcv, temp_padl); - CvSTART(cv) = CvSTART(compcv); - CvSTART(compcv) = cvstart; - CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); - CvFLAGS(compcv) |= other_flags; - - if (free_file) { - Safefree(CvFILE(cv)); - CvFILE(cv) = NULL; - } - - /* inner references to compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); - if (PERLDB_INTER)/* Advice debugger on the new sub. */ + cv_flags_t preserved_flags = + CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); + PADLIST *const temp_padl = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + SvPOK_off(cv); + CvFLAGS(cv) = + CvFLAGS(compcv) | preserved_flags; + CvOUTSIDE(cv) = CvOUTSIDE(compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv); + CvPADLIST_set(cv, CvPADLIST(compcv)); + CvOUTSIDE(compcv) = temp_cv; + CvPADLIST_set(compcv, temp_padl); + CvSTART(cv) = CvSTART(compcv); + CvSTART(compcv) = cvstart; + CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(compcv) |= other_flags; + + if (free_file) { + Safefree(CvFILE(cv)); + CvFILE(cv) = NULL; + } + + /* inner references to compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; - } - else { - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); - } - /* ... before we throw it away */ - SvREFCNT_dec(compcv); - PL_compcv = compcv = cv; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(compcv); + PL_compcv = compcv = cv; } else { - cv = compcv; - *spot = cv; + cv = compcv; + *spot = cv; } setname: CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - if (hek) (void)share_hek_hek(hek); - else { - dVAR; - U32 hash; - PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); - hek = share_hek(PadnamePV(name)+1, - (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), - hash); - } - CvNAME_HEK_set(cv, hek); + if (hek) (void)share_hek_hek(hek); + else { + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, + (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1), + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) @@ -10990,7 +11236,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH_set(cv, PL_curstash); if (ps) { - sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if (ps_utf8) SvUTF8_on(MUTABLE_SV(cv)); } @@ -11015,75 +11261,74 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) attrs: if (attrs) { - /* Need to do a C. */ - apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); + /* Need to do a C. */ + apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs); } if (block) { - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); - GV * const db_postponed = gv_fetchpvs("DB::postponed", - GV_ADDMULTI, SVt_PVHV); - HV *hv; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", - CopFILE(PL_curcop), - (long)PL_subline, - (long)CopLINE(PL_curcop)); - if (HvNAME_HEK(PL_curstash)) { - sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); - sv_catpvs(tmpstr, "::"); - } - else + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = sv_newmortal(); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + if (HvNAME_HEK(PL_curstash)) { + sv_sethek(tmpstr, HvNAME_HEK(PL_curstash)); + sv_catpvs(tmpstr, "::"); + } + else sv_setpvs(tmpstr, "__ANON__::"); - sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, - PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); - (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), - SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); - hv = GvHVn(db_postponed); - if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { - CV * const pcv = GvCV(db_postponed); - if (pcv) { - dSP; - PUSHMARK(SP); - XPUSHs(tmpstr); - PUTBACK; - call_sv(MUTABLE_SV(pcv), G_DISCARD); - } - } - } + sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1, + PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES); + (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } } clone: if (clonee) { - assert(CvDEPTH(outcv)); - spot = (CV **) - &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; - if (reusable) + assert(CvDEPTH(outcv)); + spot = (CV **) + &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax]; + if (reusable) cv_clone_into(clonee, *spot); - else *spot = cv_clone(clonee); - SvREFCNT_dec_NN(clonee); - cv = *spot; + else *spot = cv_clone(clonee); + SvREFCNT_dec_NN(clonee); + cv = *spot; } if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { - PADOFFSET depth = CvDEPTH(outcv); - while (--depth) { - SV *oldcv; - svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; - oldcv = *svspot; - *svspot = SvREFCNT_inc_simple_NN(cv); - SvREFCNT_dec(oldcv); - } + PADOFFSET depth = CvDEPTH(outcv); + while (--depth) { + SV *oldcv; + svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax]; + oldcv = *svspot; + *svspot = SvREFCNT_inc_simple_NN(cv); + SvREFCNT_dec(oldcv); + } } done: if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS if (slab) - Slab_to_ro(slab); + Slab_to_ro(slab); #endif op_free(o); return cv; @@ -11135,7 +11380,7 @@ this function. If C is false and C is null, then the subroutine will be anonymous. If C is false and C is non-null, then C -must point to a C op, which will be consumed by this function, +must point to a C OP, which will be consumed by this function, and its string value supplies a name for the subroutine. The name may be qualified or unqualified, and if it is unqualified then a default stash will be selected in some manner. If C is true, then C @@ -11166,13 +11411,24 @@ time this function returns, making it erroneous for the caller to make any use of the returned pointer. It is the caller's responsibility to ensure that it knows which of these situations applies. +=for apidoc newATTRSUB +Construct a Perl subroutine, also performing some surrounding jobs. + +This is the same as L> with its C parameter set to +FALSE. This means that if C is null, the new sub will be anonymous; otherwise +the name will be derived from C in the way described (as with all other +details) in L>. + +=for apidoc newSUB +Like C>, but without attributes. + =cut */ /* _x = extended */ CV * Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, - OP *block, bool o_is_gv) + OP *block, bool o_is_gv) { GV *gv; const char *ps; @@ -11187,12 +11443,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags - = ec ? GV_NOADD_NOINIT : + = ec ? GV_NOADD_NOINIT : (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) - ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; + ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; const char * const name = - o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); bool evanescent = FALSE; @@ -11202,41 +11458,41 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #endif if (o_is_gv) { - gv = (GV*)o; - o = NULL; - has_name = TRUE; + gv = (GV*)o; + o = NULL; + has_name = TRUE; } else if (name) { - /* Try to optimise and avoid creating a GV. Instead, the CV’s name - hek and CvSTASH pointer together can imply the GV. If the name - contains a package name, then GvSTASH(CvGV(cv)) may differ from - CvSTASH, so forego the optimisation if we find any. - Also, we may be called from load_module at run time, so - PL_curstash (which sets CvSTASH) may not point to the stash the - sub is stored in. */ - /* XXX This optimization is currently disabled for packages other - than main, since there was too much CPAN breakage. */ - const I32 flags = - ec ? GV_NOADD_NOINIT - : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)) - || PL_curstash != PL_defstash - || memchr(name, ':', namlen) || memchr(name, '\'', namlen) - ? gv_fetch_flags - : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; - gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); - has_name = TRUE; + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + /* XXX This optimization is currently disabled for packages other + than main, since there was too much CPAN breakage. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop)) + || PL_curstash != PL_defstash + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); + has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { - SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", - PL_curstash ? "__ANON__" : "__ANON__::__ANON__", - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); - has_name = TRUE; + SV * const sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", + PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; } else if (PL_curstash) { - gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); - has_name = FALSE; + gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } else { - gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); - has_name = FALSE; + gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } if (!ec) { @@ -11249,12 +11505,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (proto) { - assert(proto->op_type == OP_CONST); - ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + assert(proto->op_type == OP_CONST); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } else - ps = NULL; + ps = NULL; if (o) SAVEFREEOP(o); @@ -11264,29 +11520,29 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SAVEFREEOP(attrs); if (ec) { - op_free(block); + op_free(block); - if (name) + if (name) SvREFCNT_dec(PL_compcv); - else + else cv = PL_compcv; - PL_compcv = 0; - if (name && block) { - const char *s = (char *) my_memrchr(name, ':', namlen); - s = s ? s+1 : name; - if (strEQ(s, "BEGIN")) { - if (PL_in_eval & EVAL_KEEPERR) - Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); - else { + PL_compcv = 0; + if (name && block) { + const char *s = (char *) my_memrchr(name, ':', namlen); + s = s ? s+1 : name; + if (strEQ(s, "BEGIN")) { + if (PL_in_eval & EVAL_KEEPERR) + Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted"); + else { SV * const errsv = ERRSV; - /* force display of errors found but not reported */ - sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); - Perl_croak_nocontext("%" SVf, SVfARG(errsv)); - } - } - } - goto done; + /* force display of errors found but not reported */ + sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); + } + } + } + goto done; } if (!block && SvTYPE(gv) != SVt_PVGV) { @@ -11324,30 +11580,30 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } cv = (!name || (isGV(gv) && GvCVGEN(gv))) - ? NULL - : isGV(gv) - ? GvCV(gv) - : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV - ? (CV *)SvRV(gv) - : NULL; + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; if (block) { - assert(PL_parser); - /* This makes sub {}; work as expected. */ - if (block->op_type == OP_STUB) { - const line_t l = PL_parser->copline; - op_free(block); - block = newSTATEOP(0, NULL, 0); - PL_parser->copline = l; - } - block = CvLVALUE(PL_compcv) - || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) - && (!isGV(gv) || !GvASSUMECV(gv))) - ? newUNOP(OP_LEAVESUBLV, 0, - op_lvalue(scalarseq(block), OP_LEAVESUBLV)) - : newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - start = LINKLIST(block); - block->op_next = 0; + assert(PL_parser); + /* This makes sub {}; work as expected. */ + if (block->op_type == OP_STUB) { + const line_t l = PL_parser->copline; + op_free(block); + block = newSTATEOP(0, NULL, 0); + PL_parser->copline = l; + } + block = CvLVALUE(PL_compcv) + || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv) + && (!isGV(gv) || !GvASSUMECV(gv))) + ? newUNOP(OP_LEAVESUBLV, 0, + op_lvalue(voidnonfinal(block), OP_LEAVESUBLV)) + : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block)); + start = LINKLIST(block); + block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) const_sv = S_op_const_sv(aTHX_ start, PL_compcv, @@ -11359,36 +11615,36 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv = NULL; if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { - cv_ckproto_len_flags((const CV *)gv, - o ? (const GV *)cSVOPo->op_sv : NULL, ps, - ps_len, ps_utf8|CV_CKPROTO_CURSTASH); - if (SvROK(gv)) { - /* All the other code for sub redefinition warnings expects the - clobbered sub to be a CV. Instead of making all those code - paths more complex, just inline the RV version here. */ - const line_t oldline = CopLINE(PL_curcop); - assert(IN_PERL_COMPILETIME); - if (PL_parser && PL_parser->copline != NOLINE) - /* This ensures that warnings are reported at the first - line of a redefinition, not the last. */ - CopLINE_set(PL_curcop, PL_parser->copline); - /* protect against fatal warnings leaking compcv */ - SAVEFREESV(PL_compcv); - - if (ckWARN(WARN_REDEFINE) - || ( ckWARN_d(WARN_REDEFINE) - && ( !const_sv || SvRV(gv) == const_sv - || sv_cmp(SvRV(gv), const_sv) ))) { + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) { assert(cSVOPo); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Constant subroutine %" SVf " redefined", - SVfARG(cSVOPo->op_sv)); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %" SVf " redefined", + SVfARG(cSVOPo->op_sv)); } - SvREFCNT_inc_simple_void_NN(PL_compcv); - CopLINE_set(PL_curcop, oldline); - SvREFCNT_dec(SvRV(gv)); - } + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } } if (cv) { @@ -11400,61 +11656,61 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, */ if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); - /* already defined (or promised)? */ - if (exists || (isGV(gv) && GvASSUMECV(gv))) { - S_already_defined(aTHX_ cv, block, o, NULL, &const_sv); + /* already defined (or promised)? */ + if (exists || (isGV(gv) && GvASSUMECV(gv))) { + S_already_defined(aTHX_ cv, block, o, NULL, &const_sv); if (block) - cv = NULL; - else { - if (attrs) + cv = NULL; + else { + if (attrs) goto attrs; - /* just a "sub foo;" when &foo is already defined */ - SAVEFREESV(PL_compcv); - goto done; - } - } + /* just a "sub foo;" when &foo is already defined */ + SAVEFREESV(PL_compcv); + goto done; + } + } } if (const_sv) { - SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) |= SVs_PADTMP; - if (cv) { - assert(!CvROOT(cv) && !CvCONST(cv)); - cv_forget_slab(cv); + SvREFCNT_inc_simple_void_NN(const_sv); + SvFLAGS(const_sv) |= SVs_PADTMP; + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + cv_forget_slab(cv); SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ - CvXSUBANY(cv).any_ptr = const_sv; - CvXSUB(cv) = const_sv_xsub; - CvCONST_on(cv); - CvISXSUB_on(cv); - PoisonPADLIST(cv); - CvFLAGS(cv) |= CvMETHOD(PL_compcv); - } - else { - if (isGV(gv) || CvMETHOD(PL_compcv)) { - if (name && isGV(gv)) - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); - assert(cv); - assert(SvREFCNT((SV*)cv) != 0); - CvFLAGS(cv) |= CvMETHOD(PL_compcv); - } - else { - if (!SvROK(gv)) { - SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); - prepare_SV_for_RV((SV *)gv); - SvOK_off((SV *)gv); - SvROK_on(gv); - } - SvRV_set(gv, const_sv); - } - } - op_free(block); - SvREFCNT_dec(PL_compcv); - PL_compcv = NULL; - goto done; + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + CvISXSUB_on(cv); + PoisonPADLIST(cv); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + else { + if (isGV(gv) || CvMETHOD(PL_compcv)) { + if (name && isGV(gv)) + GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + assert(cv); + assert(SvREFCNT((SV*)cv) != 0); + CvFLAGS(cv) |= CvMETHOD(PL_compcv); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + goto done; } /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */ @@ -11462,108 +11718,106 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv = NULL; if (cv) { /* must reuse cv if autoloaded */ - /* transfer PL_compcv to cv */ - if (block) { + /* transfer PL_compcv to cv */ + if (block) { bool free_file = CvFILE(cv) && CvDYNFILE(cv); - cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; - PADLIST *const temp_av = CvPADLIST(cv); - CV *const temp_cv = CvOUTSIDE(cv); - const cv_flags_t other_flags = - CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); - OP * const cvstart = CvSTART(cv); - - if (isGV(gv)) { - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); - } - else { - dVAR; - U32 hash; - PERL_HASH(hash, name, namlen); - CvNAME_HEK_set(cv, - share_hek(name, - name_is_utf8 - ? -(SSize_t)namlen - : (SSize_t)namlen, - hash)); - } - - SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs - | CvNAMED(cv); - CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvPADLIST_set(cv,CvPADLIST(PL_compcv)); - CvOUTSIDE(PL_compcv) = temp_cv; - CvPADLIST_set(PL_compcv, temp_av); - CvSTART(cv) = CvSTART(PL_compcv); - CvSTART(PL_compcv) = cvstart; - CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); - CvFLAGS(PL_compcv) |= other_flags; - - if (free_file) { - Safefree(CvFILE(cv)); + cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; + PADLIST *const temp_av = CvPADLIST(cv); + CV *const temp_cv = CvOUTSIDE(cv); + const cv_flags_t other_flags = + CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); + OP * const cvstart = CvSTART(cv); + + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } + + SvPOK_off(cv); + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvPADLIST_set(cv,CvPADLIST(PL_compcv)); + CvOUTSIDE(PL_compcv) = temp_cv; + CvPADLIST_set(PL_compcv, temp_av); + CvSTART(cv) = CvSTART(PL_compcv); + CvSTART(PL_compcv) = cvstart; + CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE); + CvFLAGS(PL_compcv) |= other_flags; + + if (free_file) { + Safefree(CvFILE(cv)); } - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); - /* inner references to PL_compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); - if (PERLDB_INTER)/* Advice debugger on the new sub. */ + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ ++PL_sub_generation; - } - else { - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); - } - /* ... before we throw it away */ - SvREFCNT_dec(PL_compcv); - PL_compcv = cv; + } + else { + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); + } + /* ... before we throw it away */ + SvREFCNT_dec(PL_compcv); + PL_compcv = cv; } else { - cv = PL_compcv; - if (name && isGV(gv)) { - GvCV_set(gv, cv); - GvCVGEN(gv) = 0; - if (HvENAME_HEK(GvSTASH(gv))) - /* sub Foo::bar { (shift)+1 } */ - gv_method_changed(gv); - } - else if (name) { - if (!SvROK(gv)) { - SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); - prepare_SV_for_RV((SV *)gv); - SvOK_off((SV *)gv); - SvROK_on(gv); - } - SvRV_set(gv, (SV *)cv); - if (HvENAME_HEK(PL_curstash)) - mro_method_changed_in(PL_curstash); - } + cv = PL_compcv; + if (name && isGV(gv)) { + GvCV_set(gv, cv); + GvCVGEN(gv) = 0; + if (HvENAME_HEK(GvSTASH(gv))) + /* sub Foo::bar { (shift)+1 } */ + gv_method_changed(gv); + } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + if (HvENAME_HEK(PL_curstash)) + mro_method_changed_in(PL_curstash); + } } assert(cv); assert(SvREFCNT((SV*)cv) != 0); if (!CvHASGV(cv)) { - if (isGV(gv)) + if (isGV(gv)) CvGV_set(cv, gv); - else { - dVAR; - U32 hash; - PERL_HASH(hash, name, namlen); - CvNAME_HEK_set(cv, share_hek(name, - name_is_utf8 - ? -(SSize_t)namlen - : (SSize_t)namlen, - hash)); - } - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); + else { + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH_set(cv, PL_curstash); } if (ps) { - sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } @@ -11588,41 +11842,40 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { - /* Need to do a C. */ - HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) - ? GvSTASH(CvGV(cv)) - : PL_curstash; - if (!name) + /* Need to do a C. */ + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; + if (!name) SAVEFREESV(cv); - apply_attrs(stash, MUTABLE_SV(cv), attrs); - if (!name) + apply_attrs(stash, MUTABLE_SV(cv), attrs); + if (!name) SvREFCNT_inc_simple_void_NN(cv); } if (block && has_name) { - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = cv_name(cv,NULL,0); - GV * const db_postponed = gv_fetchpvs("DB::postponed", - GV_ADDMULTI, SVt_PVHV); - HV *hv; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", - CopFILE(PL_curcop), - (long)PL_subline, - (long)CopLINE(PL_curcop)); - (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), - SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); - hv = GvHVn(db_postponed); - if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) { - CV * const pcv = GvCV(db_postponed); - if (pcv) { - dSP; - PUSHMARK(SP); - XPUSHs(tmpstr); - PUTBACK; - call_sv(MUTABLE_SV(pcv), G_DISCARD); - } - } - } + if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { + SV * const tmpstr = cv_name(cv,NULL,0); + GV * const db_postponed = gv_fetchpvs("DB::postponed", + GV_ADDMULTI, SVt_PVHV); + HV *hv; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, + (long)CopLINE(PL_curcop)); + (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0); + hv = GvHVn(db_postponed); + if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) { + CV * const pcv = GvCV(db_postponed); + if (pcv) { + dSP; + PUSHMARK(SP); + XPUSHs(tmpstr); + PUTBACK; + call_sv(MUTABLE_SV(pcv), G_DISCARD); + } + } + } if (name) { if (PL_parser && PL_parser->error_count) @@ -11637,17 +11890,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, done: assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0); if (!evanescent) { #ifdef PERL_DEBUG_READONLY_OPS if (slab) - Slab_to_ro(slab); + Slab_to_ro(slab); #endif if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv))) - pad_add_weakref(cv); + pad_add_weakref(cv); } return cv; } @@ -11680,8 +11933,8 @@ S_clear_special_blocks(pTHX_ const char *const fullname, /* Returns true if the sub has been freed. */ STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, - GV *const gv, - CV *const cv) + GV *const gv, + CV *const cv) { const char *const colon = strrchr(fullname,':'); const char *const name = colon ? colon + 1 : fullname; @@ -11689,90 +11942,68 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS; if (*name == 'B') { - if (strEQ(name, "BEGIN")) { - const I32 oldscope = PL_scopestack_ix; + if (strEQ(name, "BEGIN")) { + const I32 oldscope = PL_scopestack_ix; dSP; (void)CvGV(cv); - if (floor) LEAVE_SCOPE(floor); - ENTER; - - SAVEVPTR(PL_curcop); - if (PL_curcop == &PL_compiling) { - /* Avoid pushing the "global" &PL_compiling onto the - * context stack. For example, a stack trace inside - * nested use's would show all calls coming from whoever - * most recently updated PL_compiling.cop_file and - * cop_line. So instead, temporarily set PL_curcop to a - * private copy of &PL_compiling. PL_curcop will soon be - * set to point back to &PL_compiling anyway but only - * after the temp value has been pushed onto the context - * stack as blk_oldcop. - * This is slightly hacky, but necessary. Note also - * that in the brief window before PL_curcop is set back - * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME - * will give the wrong answer. - */ - Newx(PL_curcop, 1, COP); - StructCopy(&PL_compiling, PL_curcop, COP); - PL_curcop->op_slabbed = 0; - SAVEFREEPV(PL_curcop); - } - + if (floor) LEAVE_SCOPE(floor); + ENTER; PUSHSTACKi(PERLSI_REQUIRE); - SAVECOPFILE(&PL_compiling); - SAVECOPLINE(&PL_compiling); + SAVECOPFILE(&PL_compiling); + SAVECOPLINE(&PL_compiling); + SAVEVPTR(PL_curcop); - DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); - GvCV_set(gv,0); /* cv has been hijacked */ - call_list(oldscope, PL_beginav); + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); + GvCV_set(gv,0); /* cv has been hijacked */ + call_list(oldscope, PL_beginav); POPSTACK; - LEAVE; - return !PL_savebegin; - } - else - return FALSE; + LEAVE; + return !PL_savebegin; + } + else + return FALSE; } else { - if (*name == 'E') { - if (strEQ(name, "END")) { - DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); - } else - return FALSE; - } else if (*name == 'U') { - if (strEQ(name, "UNITCHECK")) { - /* It's never too late to run a unitcheck block */ - Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else if (*name == 'C') { - if (strEQ(name, "CHECK")) { - if (PL_main_start) - /* diag_listed_as: Too late to run %s block */ - Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run CHECK block"); - Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else if (*name == 'I') { - if (strEQ(name, "INIT")) { - if (PL_main_start) - /* diag_listed_as: Too late to run %s block */ - Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run INIT block"); - Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); - } - else - return FALSE; - } else - return FALSE; - DEBUG_x( dump_sub(gv) ); - (void)CvGV(cv); - GvCV_set(gv,0); /* cv has been hijacked */ - return FALSE; + if (*name == 'E') { + if (strEQ(name, "END")) { + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); + } else + return FALSE; + } else if (*name == 'U') { + if (strEQ(name, "UNITCHECK")) { + /* It's never too late to run a unitcheck block */ + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); + } + else + return FALSE; + } else + return FALSE; + DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); + GvCV_set(gv,0); /* cv has been hijacked */ + return FALSE; } } @@ -11872,13 +12103,13 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, ENTER; if (IN_PERL_RUNTIME) { - /* at runtime, it's not safe to manipulate PL_curcop: it may be - * an op shared between threads. Use a non-shared COP for our - * dirty work */ - SAVEVPTR(PL_curcop); - SAVECOMPILEWARNINGS(); - PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - PL_curcop = &PL_compiling; + /* at runtime, it's not safe to manipulate PL_curcop: it may be + * an op shared between threads. Use a non-shared COP for our + * dirty work */ + SAVEVPTR(PL_curcop); + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + PL_curcop = &PL_compiling; } SAVECOPLINE(PL_curcop); CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE); @@ -11887,8 +12118,8 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { - SAVEGENERICSV(PL_curstash); - PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); + SAVEGENERICSV(PL_curstash); + PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); } /* Protect sv against leakage caused by fatal warnings. */ @@ -11899,11 +12130,11 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ cv = newXS_len_flags(name, len, - sv && SvTYPE(sv) == SVt_PVAV - ? const_av_xsub - : const_sv_xsub, - file ? file : "", "", - &sv, XS_DYNAMIC_FILENAME | flags); + sv && SvTYPE(sv) == SVt_PVAV + ? const_av_xsub + : const_sv_xsub, + file ? file : "", "", + &sv, XS_DYNAMIC_FILENAME | flags); assert(cv); assert(SvREFCNT((SV*)cv) != 0); CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv); @@ -11928,14 +12159,14 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) { PERL_ARGS_ASSERT_NEWXS; return newXS_len_flags( - name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 + name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0 ); } CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, - const char *const filename, const char *const proto, - U32 flags) + const char *const filename, const char *const proto, + U32 flags) { PERL_ARGS_ASSERT_NEWXS_FLAGS; return newXS_len_flags( @@ -12026,9 +12257,9 @@ ensure that it knows which of these situations applies. CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, - XSUBADDR_t subaddr, const char *const filename, - const char *const proto, SV **const_svp, - U32 flags) + XSUBADDR_t subaddr, const char *const filename, + const char *const proto, SV **const_svp, + U32 flags) { CV *cv; bool interleave = FALSE; @@ -12038,10 +12269,10 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, { GV * const gv = gv_fetchpvn( - name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", - name ? len : PL_curstash ? sizeof("__ANON__") - 1: - sizeof("__ANON__::__ANON__") - 1, - GV_ADDMULTI | flags, SVt_PVCV); + name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__", + name ? len : PL_curstash ? sizeof("__ANON__") - 1: + sizeof("__ANON__::__ANON__") - 1, + GV_ADDMULTI | flags, SVt_PVCV); if ((cv = (name ? GvCV(gv) : NULL))) { if (GvCVGEN(gv)) { @@ -12077,8 +12308,8 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, gv_method_changed(gv); /* newXS */ } } - assert(cv); - assert(SvREFCNT((SV*)cv) != 0); + assert(cv); + assert(SvREFCNT((SV*)cv) != 0); CvGV_set(cv, gv); if(filename) { @@ -12099,7 +12330,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, } CvISXSUB_on(cv); CvXSUB(cv) = subaddr; -#ifndef PERL_IMPLICIT_CONTEXT +#ifndef MULTIPLICITY CvHSCXT(cv) = &PL_stack_sp; #else PoisonPADLIST(cv); @@ -12134,10 +12365,10 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake) GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv))) - gv_method_changed(gv); + gv_method_changed(gv); if (SvFAKE(gv)) { - cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); - SvFAKE_off(cvgv); + cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV); + SvFAKE_off(cvgv); } else cvgv = gv; CvGV_set(cv, cvgv); @@ -12156,31 +12387,31 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OP *start; if (PL_parser && PL_parser->error_count) { - op_free(block); - goto finish; + op_free(block); + goto finish; } gv = o - ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) - : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); + ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) + : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM); GvMULTI_on(gv); if ((cv = GvFORM(gv))) { - if (ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) - CopLINE_set(PL_curcop, PL_parser->copline); - if (o) { - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); - } else { - /* diag_listed_as: Format %s redefined */ - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Format STDOUT redefined"); - } - CopLINE_set(PL_curcop, oldline); - } - SvREFCNT_dec(cv); + if (ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); + } else { + /* diag_listed_as: Format %s redefined */ + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); } cv = PL_compcv; GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv); @@ -12188,7 +12419,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvFILE_set_from_cop(cv, PL_curcop); - root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); + root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block)); CvROOT(cv) = root; start = LINKLIST(root); root->op_next = 0; @@ -12198,7 +12429,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) finish: op_free(o); if (PL_parser) - PL_parser->copline = NOLINE; + PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); PL_compiling.cop_seq = 0; } @@ -12226,20 +12457,19 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)); OP * anoncode = - newSVOP(OP_ANONCODE, 0, - cv); + newSVOP(OP_ANONCODE, 0, + cv); if (CvANONCONST(cv)) - anoncode = newUNOP(OP_ANONCONST, 0, - op_convert_list(OP_ENTERSUB, - OPf_STACKED|OPf_WANT_SCALAR, - anoncode)); + anoncode = newUNOP(OP_ANONCONST, 0, + op_convert_list(OP_ENTERSUB, + OPf_STACKED|OPf_WANT_SCALAR, + anoncode)); return newUNOP(OP_REFGEN, 0, anoncode); } OP * Perl_oopsAV(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_OOPSAV; @@ -12247,17 +12477,17 @@ Perl_oopsAV(pTHX_ OP *o) case OP_PADSV: case OP_PADHV: OpTYPE_set(o, OP_PADAV); - return ref(o, OP_RV2AV); + return ref(o, OP_RV2AV); case OP_RV2SV: case OP_RV2HV: OpTYPE_set(o, OP_RV2AV); - ref(o, OP_RV2AV); - break; + ref(o, OP_RV2AV); + break; default: - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); - break; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); + break; } return o; } @@ -12265,7 +12495,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_OOPSHV; @@ -12273,19 +12502,19 @@ Perl_oopsHV(pTHX_ OP *o) case OP_PADSV: case OP_PADAV: OpTYPE_set(o, OP_PADHV); - return ref(o, OP_RV2HV); + return ref(o, OP_RV2HV); case OP_RV2SV: case OP_RV2AV: OpTYPE_set(o, OP_RV2HV); /* rv2hv steals the bottom bit for its own uses */ o->op_private &= ~OPpARG1_MASK; - ref(o, OP_RV2HV); - break; + ref(o, OP_RV2HV); + break; default: - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); - break; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); + break; } return o; } @@ -12293,16 +12522,15 @@ Perl_oopsHV(pTHX_ OP *o) OP * Perl_newAVREF(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_NEWAVREF; if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADAV); - return o; + return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { - Perl_croak(aTHX_ "Can't use an array as a reference"); + Perl_croak(aTHX_ "Can't use an array as a reference"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -12311,23 +12539,22 @@ OP * Perl_newGVREF(pTHX_ I32 type, OP *o) { if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT) - return newUNOP(OP_NULL, 0, o); + return newUNOP(OP_NULL, 0, o); return ref(newUNOP(OP_RV2GV, OPf_REF, o), type); } OP * Perl_newHVREF(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_NEWHVREF; if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADHV); - return o; + return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { - Perl_croak(aTHX_ "Can't use a hash as a reference"); + Perl_croak(aTHX_ "Can't use a hash as a reference"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -12336,7 +12563,6 @@ OP * Perl_newCVREF(pTHX_ I32 flags, OP *o) { if (o->op_type == OP_PADANY) { - dVAR; OpTYPE_set(o, OP_PADCV); } return newUNOP(OP_RV2CV, flags, scalar(o)); @@ -12345,14 +12571,13 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) OP * Perl_newSVREF(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_NEWSVREF; if (o->op_type == OP_PADANY) { OpTYPE_set(o, OP_PADSV); scalar(o); - return o; + return o; } return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -12375,39 +12600,39 @@ S_io_hints(pTHX_ OP *o) { #if O_BINARY != 0 || O_TEXT != 0 HV * const table = - PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; + PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; if (table) { - SV **svp = hv_fetchs(table, "open_IN", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); + SV **svp = hv_fetchs(table, "open_IN", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ # if O_BINARY != 0 - if (mode & O_BINARY) - o->op_private |= OPpOPEN_IN_RAW; + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; # endif # if O_TEXT != 0 - if (mode & O_TEXT) - o->op_private |= OPpOPEN_IN_CRLF; + if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; # endif - } + } - svp = hv_fetchs(table, "open_OUT", FALSE); - if (svp && *svp) { - STRLEN len = 0; - const char *d = SvPV_const(*svp, len); - const I32 mode = mode_from_discipline(d, len); + svp = hv_fetchs(table, "open_OUT", FALSE); + if (svp && *svp) { + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ # if O_BINARY != 0 - if (mode & O_BINARY) - o->op_private |= OPpOPEN_OUT_RAW; + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; # endif # if O_TEXT != 0 - if (mode & O_TEXT) - o->op_private |= OPpOPEN_OUT_CRLF; + if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; # endif - } + } } #else PERL_UNUSED_CONTEXT; @@ -12429,13 +12654,13 @@ Perl_ck_backtick(pTHX_ OP *o) { /* detach rest of siblings from o and its first child */ op_sibling_splice(o, cUNOPo->op_first, -1, NULL); - newop = S_new_entersubop(aTHX_ gv, sibl); + newop = S_new_entersubop(aTHX_ gv, sibl); } else if (!(o->op_flags & OPf_KIDS)) - newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); + newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); if (newop) { - op_free(o); - return newop; + op_free(o); + return newop; } S_io_hints(aTHX_ o); return o; @@ -12446,28 +12671,29 @@ Perl_ck_bitop(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_BITOP; - o->op_private = (U8)(PL_hints & HINT_INTEGER); + /* get rid of arg count and indicate if in the scope of 'use integer' */ + o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0; if (!(o->op_flags & OPf_STACKED) /* Not an assignment */ - && OP_IS_INFIX_BIT(o->op_type)) + && OP_IS_INFIX_BIT(o->op_type)) { - const OP * const left = cBINOPo->op_first; - const OP * const right = OpSIBLING(left); - if ((OP_IS_NUMCOMPARE(left->op_type) && - (left->op_flags & OPf_PARENS) == 0) || - (OP_IS_NUMCOMPARE(right->op_type) && - (right->op_flags & OPf_PARENS) == 0)) - Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), - "Possible precedence problem on bitwise %s operator", - o->op_type == OP_BIT_OR - ||o->op_type == OP_NBIT_OR ? "|" - : o->op_type == OP_BIT_AND - ||o->op_type == OP_NBIT_AND ? "&" - : o->op_type == OP_BIT_XOR - ||o->op_type == OP_NBIT_XOR ? "^" - : o->op_type == OP_SBIT_OR ? "|." - : o->op_type == OP_SBIT_AND ? "&." : "^." - ); + const OP * const left = cBINOPo->op_first; + const OP * const right = OpSIBLING(left); + if ((OP_IS_NUMCOMPARE(left->op_type) && + (left->op_flags & OPf_PARENS) == 0) || + (OP_IS_NUMCOMPARE(right->op_type) && + (right->op_flags & OPf_PARENS) == 0)) + Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %s operator", + o->op_type == OP_BIT_OR + ||o->op_type == OP_NBIT_OR ? "|" + : o->op_type == OP_BIT_AND + ||o->op_type == OP_NBIT_AND ? "&" + : o->op_type == OP_BIT_XOR + ||o->op_type == OP_NBIT_XOR ? "^" + : o->op_type == OP_SBIT_OR ? "|." + : o->op_type == OP_SBIT_AND ? "&." : "^." + ); } return o; } @@ -12478,9 +12704,9 @@ is_dollar_bracket(pTHX_ const OP * const o) const OP *kid; PERL_UNUSED_CONTEXT; return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS - && (kid = cUNOPx(o)->op_first) - && kid->op_type == OP_GV - && strEQ(GvNAME(cGVOPx_gv(kid)), "["); + && (kid = cUNOPx(o)->op_first) + && kid->op_type == OP_GV + && strEQ(GvNAME(cGVOPx_gv(kid)), "["); } /* for lt, gt, le, ge, eq, ne and their i_ variants */ @@ -12504,19 +12730,19 @@ Perl_ck_cmp(pTHX_ OP *o) || o->op_type == OP_I_NE); if (!is_eq && ckWARN(WARN_SYNTAX)) { - const OP *kid = cUNOPo->op_first; - if (kid && + const OP *kid = cUNOPo->op_first; + if (kid && ( - ( is_dollar_bracket(aTHX_ kid) + ( is_dollar_bracket(aTHX_ kid) && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST - ) - || ( kid->op_type == OP_CONST - && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) ) - ) + || ( kid->op_type == OP_CONST + && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) ) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "$[ used in %s (did you mean $] ?)", OP_DESC(o)); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "$[ used in %s (did you mean $] ?)", OP_DESC(o)); } /* convert (index(...) == -1) and variations into @@ -12609,7 +12835,7 @@ Perl_ck_concat(pTHX_ OP *o) /* reuse the padtmp returned by the concat child */ if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) && - !(kUNOP->op_first->op_flags & OPf_MOD)) + !(kUNOP->op_first->op_flags & OPf_MOD)) { o->op_flags |= OPf_STACKED; o->op_private |= OPpCONCAT_NESTED; @@ -12620,35 +12846,34 @@ Perl_ck_concat(pTHX_ OP *o) OP * Perl_ck_spair(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_CK_SPAIR; if (o->op_flags & OPf_KIDS) { - OP* newop; - OP* kid; + OP* newop; + OP* kid; OP* kidkid; - const OPCODE type = o->op_type; - o = modkids(ck_fun(o), type); - kid = cUNOPo->op_first; - kidkid = kUNOP->op_first; - newop = OpSIBLING(kidkid); - if (newop) { - const OPCODE type = newop->op_type; - if (OpHAS_SIBLING(newop)) - return o; - if (o->op_type == OP_REFGEN - && ( type == OP_RV2CV - || ( !(newop->op_flags & OPf_PARENS) - && ( type == OP_RV2AV || type == OP_PADAV - || type == OP_RV2HV || type == OP_PADHV)))) - NOOP; /* OK (allow srefgen for \@a and \%h) */ - else if (OP_GIMME(newop,0) != G_SCALAR) - return o; - } + const OPCODE type = o->op_type; + o = modkids(ck_fun(o), type); + kid = cUNOPo->op_first; + kidkid = kUNOP->op_first; + newop = OpSIBLING(kidkid); + if (newop) { + const OPCODE type = newop->op_type; + if (OpHAS_SIBLING(newop)) + return o; + if (o->op_type == OP_REFGEN + && ( type == OP_RV2CV + || ( !(newop->op_flags & OPf_PARENS) + && ( type == OP_RV2AV || type == OP_PADAV + || type == OP_RV2HV || type == OP_PADHV)))) + NOOP; /* OK (allow srefgen for \@a and \%h) */ + else if (OP_GIMME(newop,0) != G_SCALAR) + return o; + } /* excise first sibling */ op_sibling_splice(kid, NULL, 1, NULL); - op_free(kidkid); + op_free(kidkid); } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, * and OP_CHOMP into OP_SCHOMP */ @@ -12664,32 +12889,32 @@ Perl_ck_delete(pTHX_ OP *o) o = ck_fun(o); o->op_private = 0; if (o->op_flags & OPf_KIDS) { - OP * const kid = cUNOPo->op_first; - switch (kid->op_type) { - case OP_ASLICE: - o->op_flags |= OPf_SPECIAL; - /* FALLTHROUGH */ - case OP_HSLICE: - o->op_private |= OPpSLICE; - break; - case OP_AELEM: - o->op_flags |= OPf_SPECIAL; - /* FALLTHROUGH */ - case OP_HELEM: - break; - case OP_KVASLICE: + OP * const kid = cUNOPo->op_first; + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALLTHROUGH */ + case OP_HSLICE: + o->op_private |= OPpSLICE; + break; + case OP_AELEM: + o->op_flags |= OPf_SPECIAL; + /* FALLTHROUGH */ + case OP_HELEM: + break; + case OP_KVASLICE: o->op_flags |= OPf_SPECIAL; /* FALLTHROUGH */ - case OP_KVHSLICE: + case OP_KVHSLICE: o->op_private |= OPpKVSLICE; break; - default: - Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " - "element or slice"); - } - if (kid->op_private & OPpLVAL_INTRO) - o->op_private |= OPpLVAL_INTRO; - op_null(kid); + default: + Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY " + "element or slice"); + } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; + op_null(kid); } return o; } @@ -12700,17 +12925,17 @@ Perl_ck_eof(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { - OP *kid; - if (cLISTOPo->op_first->op_type == OP_STUB) { - OP * const newop - = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); - op_free(o); - o = newop; - } - o = ck_fun(o); - kid = cLISTOPo->op_first; - if (kid->op_type == OP_RV2GV) - kid->op_private |= OPpALLOW_FAKE; + OP *kid; + if (cLISTOPo->op_first->op_type == OP_STUB) { + OP * const newop + = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + o = newop; + } + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) + kid->op_private |= OPpALLOW_FAKE; } return o; } @@ -12719,63 +12944,125 @@ Perl_ck_eof(pTHX_ OP *o) OP * Perl_ck_eval(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_CK_EVAL; PL_hints |= HINT_BLOCK_SCOPE; if (o->op_flags & OPf_KIDS) { - SVOP * const kid = (SVOP*)cUNOPo->op_first; - assert(kid); + SVOP * const kid = (SVOP*)cUNOPo->op_first; + assert(kid); - if (o->op_type == OP_ENTERTRY) { - LOGOP *enter; + if (o->op_type == OP_ENTERTRY) { + LOGOP *enter; /* cut whole sibling chain free from o */ op_sibling_splice(o, NULL, -1, NULL); - op_free(o); + op_free(o); enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL); - /* establish postfix order */ - enter->op_next = (OP*)enter; + /* establish postfix order */ + enter->op_next = (OP*)enter; - o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); + o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); OpTYPE_set(o, OP_LEAVETRY); - enter->op_other = o; - return o; - } - else { - scalar((OP*)kid); - S_set_haseval(aTHX); - } + enter->op_other = o; + return o; + } + else { + scalar((OP*)kid); + S_set_haseval(aTHX); + } } else { - const U8 priv = o->op_private; - op_free(o); + const U8 priv = o->op_private; + op_free(o); /* the newUNOP will recursively call ck_eval(), which will handle * all the stuff at the end of this function, like adding * OP_HINTSEVAL */ - return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); + return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { - /* Store a copy of %^H that pp_entereval can pick up. */ + /* Store a copy of %^H that pp_entereval can pick up. */ HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv)); - OP *hhop; + OP *hhop; STOREFEATUREBITSHH(hh); hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh)); /* append hhop to only child */ op_sibling_splice(o, cUNOPo->op_first, 0, hhop); - o->op_private |= OPpEVAL_HAS_HH; + o->op_private |= OPpEVAL_HAS_HH; } if (!(o->op_private & OPpEVAL_BYTES) - && FEATURE_UNIEVAL_IS_ENABLED) - o->op_private |= OPpEVAL_UNICODE; + && FEATURE_UNIEVAL_IS_ENABLED) + o->op_private |= OPpEVAL_UNICODE; + return o; +} + +OP * +Perl_ck_trycatch(pTHX_ OP *o) +{ + LOGOP *enter; + OP *to_free = NULL; + OP *trykid, *catchkid; + OP *catchroot, *catchstart; + + PERL_ARGS_ASSERT_CK_TRYCATCH; + + trykid = cUNOPo->op_first; + if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) { + to_free = trykid; + trykid = OpSIBLING(trykid); + } + catchkid = OpSIBLING(trykid); + + assert(trykid->op_type == OP_POPTRY); + assert(catchkid->op_type == OP_CATCH); + + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); + if(to_free) + op_free(to_free); + op_free(o); + + enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL); + + /* establish postfix order */ + enter->op_next = (OP*)enter; + + o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid); + op_append_elem(OP_LINESEQ, (OP*)o, catchkid); + + OpTYPE_set(o, OP_LEAVETRYCATCH); + + /* The returned optree is actually threaded up slightly nonobviously in + * terms of its ->op_next pointers. + * + * This way, if the tryblock dies, its retop points at the OP_CATCH, but + * if it does not then its leavetry skips over that and continues + * execution past it. + */ + + /* First, link up the actual body of the catch block */ + catchroot = OpSIBLING(cUNOPx(catchkid)->op_first); + catchstart = LINKLIST(catchroot); + cLOGOPx(catchkid)->op_other = catchstart; + + o->op_next = LINKLIST(o); + + /* die within try block should jump to the catch */ + enter->op_other = catchkid; + + /* after try block that doesn't die, just skip straight to leavetrycatch */ + trykid->op_next = o; + + /* after catch block, skip back up to the leavetrycatch */ + catchroot->op_next = o; + return o; } @@ -12786,13 +13073,13 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; - o = ck_fun(o); - kid = OpSIBLING(cUNOPo->op_first); - if (kid->op_type == OP_RV2GV) - op_null(kid); + o = ck_fun(o); + kid = OpSIBLING(cUNOPo->op_first); + if (kid->op_type == OP_RV2GV) + op_null(kid); } else - o = listkids(o); + o = listkids(o); return o; } @@ -12803,21 +13090,21 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { - OP * const kid = cUNOPo->op_first; - if (kid->op_type == OP_ENTERSUB) { - (void) ref(kid, o->op_type); - if (kid->op_type != OP_RV2CV - && !(PL_parser && PL_parser->error_count)) - Perl_croak(aTHX_ - "exists argument is not a subroutine name"); - o->op_private |= OPpEXISTS_SUB; - } - else if (kid->op_type == OP_AELEM) - o->op_flags |= OPf_SPECIAL; - else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " - "element or a subroutine"); - op_null(kid); + OP * const kid = cUNOPo->op_first; + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV + && !(PL_parser && PL_parser->error_count)) + Perl_croak(aTHX_ + "exists argument is not a subroutine name"); + o->op_private |= OPpEXISTS_SUB; + } + else if (kid->op_type == OP_AELEM) + o->op_flags |= OPf_SPECIAL; + else if (kid->op_type != OP_HELEM) + Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY " + "element or a subroutine"); + op_null(kid); } return o; } @@ -12825,7 +13112,6 @@ Perl_ck_exists(pTHX_ OP *o) OP * Perl_ck_rvconst(pTHX_ OP *o) { - dVAR; SVOP * const kid = (SVOP*)cUNOPo->op_first; PERL_ARGS_ASSERT_CK_RVCONST; @@ -12837,82 +13123,82 @@ Perl_ck_rvconst(pTHX_ OP *o) o->op_private |= (PL_hints & HINT_STRICT_REFS); if (kid->op_type == OP_CONST) { - int iscv; - GV *gv; - SV * const kidsv = kid->op_sv; - - /* Is it a constant from cv_const_sv()? */ - if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { - return o; - } - if (SvTYPE(kidsv) == SVt_PVAV) return o; - if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { - const char *badthing; - switch (o->op_type) { - case OP_RV2SV: - badthing = "a SCALAR"; - break; - case OP_RV2AV: - badthing = "an ARRAY"; - break; - case OP_RV2HV: - badthing = "a HASH"; - break; - default: - badthing = NULL; - break; - } - if (badthing) - Perl_croak(aTHX_ - "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", - SVfARG(kidsv), badthing); - } - /* - * This is a little tricky. We only want to add the symbol if we - * didn't add it in the lexer. Otherwise we get duplicate strict - * warnings. But if we didn't add it in the lexer, we must at - * least pretend like we wanted to add it even if it existed before, - * or we get possible typo warnings. OPpCONST_ENTERED says - * whether the lexer already added THIS instance of this symbol. - */ - iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; - gv = gv_fetchsv(kidsv, - o->op_type == OP_RV2CV - && o->op_private & OPpMAY_RETURN_CONSTANT - ? GV_NOEXPAND - : iscv | !(kid->op_private & OPpCONST_ENTERED), - iscv - ? SVt_PVCV - : o->op_type == OP_RV2SV - ? SVt_PV - : o->op_type == OP_RV2AV - ? SVt_PVAV - : o->op_type == OP_RV2HV - ? SVt_PVHV - : SVt_PVGV); - if (gv) { - if (!isGV(gv)) { - assert(iscv); - assert(SvROK(gv)); - if (!(o->op_private & OPpMAY_RETURN_CONSTANT) - && SvTYPE(SvRV(gv)) != SVt_PVCV) - gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); - } + int iscv; + GV *gv; + SV * const kidsv = kid->op_sv; + + /* Is it a constant from cv_const_sv()? */ + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { + return o; + } + if (SvTYPE(kidsv) == SVt_PVAV) return o; + if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) { + const char *badthing; + switch (o->op_type) { + case OP_RV2SV: + badthing = "a SCALAR"; + break; + case OP_RV2AV: + badthing = "an ARRAY"; + break; + case OP_RV2HV: + badthing = "a HASH"; + break; + default: + badthing = NULL; + break; + } + if (badthing) + Perl_croak(aTHX_ + "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", + SVfARG(kidsv), badthing); + } + /* + * This is a little tricky. We only want to add the symbol if we + * didn't add it in the lexer. Otherwise we get duplicate strict + * warnings. But if we didn't add it in the lexer, we must at + * least pretend like we wanted to add it even if it existed before, + * or we get possible typo warnings. OPpCONST_ENTERED says + * whether the lexer already added THIS instance of this symbol. + */ + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv + ? SVt_PVCV + : o->op_type == OP_RV2SV + ? SVt_PV + : o->op_type == OP_RV2AV + ? SVt_PVAV + : o->op_type == OP_RV2HV + ? SVt_PVHV + : SVt_PVGV); + if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } OpTYPE_set(kid, OP_GV); - SvREFCNT_dec(kid->op_sv); + SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS - /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ - STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); - SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); + /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ + STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP)); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); + SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); + PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else - kid->op_sv = SvREFCNT_inc_simple_NN(gv); + kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif - kid->op_private = 0; - /* FAKE globs in the symbol table cause weird bugs (#77810) */ - SvFAKE_off(gv); - } + kid->op_private = 0; + /* FAKE globs in the symbol table cause weird bugs (#77810) */ + SvFAKE_off(gv); + } } return o; } @@ -12920,25 +13206,24 @@ Perl_ck_rvconst(pTHX_ OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_FTST; if (o->op_flags & OPf_REF) { - NOOP; + NOOP; } else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { - SVOP * const kid = (SVOP*)cUNOPo->op_first; - const OPCODE kidtype = kid->op_type; - - if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) - && !kid->op_folded) { - OP * const newop = newGVOP(type, OPf_REF, - gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); - op_free(o); - return newop; - } + SVOP * const kid = (SVOP*)cUNOPo->op_first; + const OPCODE kidtype = kid->op_type; + + if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) + && !kid->op_folded) { + OP * const newop = newGVOP(type, OPf_REF, + gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); + op_free(o); + return newop; + } if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) { SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2); @@ -12952,27 +13237,27 @@ Perl_ck_ftst(pTHX_ OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat); } } - scalar((OP *) kid); - if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) - o->op_private |= OPpFT_ACCESS; - if (OP_IS_FILETEST(type) + scalar((OP *) kid); + if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) + o->op_private |= OPpFT_ACCESS; + if (OP_IS_FILETEST(type) && OP_IS_FILETEST(kidtype) ) { - o->op_private |= OPpFT_STACKED; - kid->op_private |= OPpFT_STACKING; - if (kidtype == OP_FTTTY && ( - !(kid->op_private & OPpFT_STACKED) - || kid->op_private & OPpFT_AFTER_t - )) - o->op_private |= OPpFT_AFTER_t; - } + o->op_private |= OPpFT_STACKED; + kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; + } } else { - op_free(o); - if (type == OP_FTTTY) - o = newGVOP(type, OPf_REF, PL_stdingv); - else - o = newUNOP(type, 0, newDEFSVOP()); + op_free(o); + if (type == OP_FTTTY) + o = newGVOP(type, OPf_REF, PL_stdingv); + else + o = newUNOP(type, 0, newDEFSVOP()); } return o; } @@ -12986,252 +13271,257 @@ Perl_ck_fun(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_FUN; if (o->op_flags & OPf_STACKED) { - if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) - oa &= ~OA_OPTIONAL; - else - return no_fh_allowed(o); + if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) + oa &= ~OA_OPTIONAL; + else + return no_fh_allowed(o); } if (o->op_flags & OPf_KIDS) { OP *prev_kid = NULL; OP *kid = cLISTOPo->op_first; I32 numargs = 0; - bool seen_optional = FALSE; - - if (kid->op_type == OP_PUSHMARK || - (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) - { - prev_kid = kid; - kid = OpSIBLING(kid); - } - if (kid && kid->op_type == OP_COREARGS) { - bool optional = FALSE; - while (oa) { - numargs++; - if (oa & OA_OPTIONAL) optional = TRUE; - oa = oa >> 4; - } - if (optional) o->op_private |= numargs; - return o; - } - - while (oa) { - if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { - if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { - kid = newDEFSVOP(); + bool seen_optional = FALSE; + + if (kid->op_type == OP_PUSHMARK || + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) + { + prev_kid = kid; + kid = OpSIBLING(kid); + } + if (kid && kid->op_type == OP_COREARGS) { + bool optional = FALSE; + while (oa) { + numargs++; + if (oa & OA_OPTIONAL) optional = TRUE; + oa = oa >> 4; + } + if (optional) o->op_private |= numargs; + return o; + } + + while (oa) { + if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { + if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { + kid = newDEFSVOP(); /* append kid to chain */ op_sibling_splice(o, prev_kid, 0, kid); } - seen_optional = TRUE; - } - if (!kid) break; - - numargs++; - switch (oa & 7) { - case OA_SCALAR: - /* list seen where single (scalar) arg expected? */ - if (numargs == 1 && !(oa >> 4) - && kid->op_type == OP_LIST && type != OP_SCALAR) - { - return too_many_arguments_pv(o,PL_op_desc[type], 0); - } - if (type != OP_DELETE) scalar(kid); - break; - case OA_LIST: - if (oa < 16) { - kid = 0; - continue; - } - else - list(kid); - break; - case OA_AVREF: - if ((type == OP_PUSH || type == OP_UNSHIFT) - && !OpHAS_SIBLING(kid)) - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless use of %s with no values", - PL_op_desc[type]); - - if (kid->op_type == OP_CONST - && ( !SvROK(cSVOPx_sv(kid)) - || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) - ) - bad_type_pv(numargs, "array", o, kid); + seen_optional = TRUE; + } + if (!kid) break; + + numargs++; + switch (oa & 7) { + case OA_SCALAR: + /* list seen where single (scalar) arg expected? */ + if (numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST && type != OP_SCALAR) + { + return too_many_arguments_pv(o,PL_op_desc[type], 0); + } + if (type != OP_DELETE) scalar(kid); + break; + case OA_LIST: + if (oa < 16) { + kid = 0; + continue; + } + else + list(kid); + break; + case OA_AVREF: + if ((type == OP_PUSH || type == OP_UNSHIFT) + && !OpHAS_SIBLING(kid)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless use of %s with no values", + PL_op_desc[type]); + + if (kid->op_type == OP_CONST + && ( !SvROK(cSVOPx_sv(kid)) + || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) + ) + bad_type_pv(numargs, "array", o, kid); else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV || kid->op_type == OP_RV2GV) { bad_type_pv(1, "array", o, kid); } - else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { + else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) { yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden", PL_op_desc[type]), 0); - } + } else { op_lvalue(kid, type); } - break; - case OA_HVREF: - if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) - bad_type_pv(numargs, "hash", o, kid); - op_lvalue(kid, type); - break; - case OA_CVREF: - { + break; + case OA_HVREF: + if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) + bad_type_pv(numargs, "hash", o, kid); + op_lvalue(kid, type); + break; + case OA_CVREF: + { /* replace kid with newop in chain */ - OP * const newop = + OP * const newop = S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); - newop->op_next = newop; - kid = newop; - } - break; - case OA_FILEREF: - if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); + newop->op_next = newop; + kid = newop; + } + break; + case OA_FILEREF: + if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) { + if (kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE)) + { + OP * const newop = newGVOP(OP_GV, 0, + gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); + /* a first argument is handled by toke.c, ideally we'd + just check here but several ops don't use ck_fun() */ + if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED && numargs > 1) { + no_bareword_filehandle(SvPVX(cSVOPx_sv((SVOP*)kid))); + } /* replace kid with newop in chain */ op_sibling_splice(o, prev_kid, 1, newop); - op_free(kid); - kid = newop; - } - else if (kid->op_type == OP_READLINE) { - /* neophyte patrol: open(), close() etc. */ - bad_type_pv(numargs, "HANDLE", o, kid); - } - else { - I32 flags = OPf_SPECIAL; - I32 priv = 0; - PADOFFSET targ = 0; - - /* is this op a FH constructor? */ - if (is_handle_constructor(o,numargs)) { + op_free(kid); + kid = newop; + } + else if (kid->op_type == OP_READLINE) { + /* neophyte patrol: open(), close() etc. */ + bad_type_pv(numargs, "HANDLE", o, kid); + } + else { + I32 flags = OPf_SPECIAL; + I32 priv = 0; + PADOFFSET targ = 0; + + /* is this op a FH constructor? */ + if (is_handle_constructor(o,numargs)) { const char *name = NULL; - STRLEN len = 0; + STRLEN len = 0; U32 name_utf8 = 0; - bool want_dollar = TRUE; - - flags = 0; - /* Set a flag to tell rv2gv to vivify - * need to "prove" flag does not mean something - * else already - NI-S 1999/05/07 - */ - priv = OPpDEREF; - if (kid->op_type == OP_PADSV) { - PADNAME * const pn - = PAD_COMPNAME_SV(kid->op_targ); - name = PadnamePV (pn); - len = PadnameLEN(pn); - name_utf8 = PadnameUTF8(pn); - } - else if (kid->op_type == OP_RV2SV - && kUNOP->op_first->op_type == OP_GV) - { - GV * const gv = cGVOPx_gv(kUNOP->op_first); - name = GvNAME(gv); - len = GvNAMELEN(gv); + bool want_dollar = TRUE; + + flags = 0; + /* Set a flag to tell rv2gv to vivify + * need to "prove" flag does not mean something + * else already - NI-S 1999/05/07 + */ + priv = OPpDEREF; + if (kid->op_type == OP_PADSV) { + PADNAME * const pn + = PAD_COMPNAME_SV(kid->op_targ); + name = PadnamePV (pn); + len = PadnameLEN(pn); + name_utf8 = PadnameUTF8(pn); + } + else if (kid->op_type == OP_RV2SV + && kUNOP->op_first->op_type == OP_GV) + { + GV * const gv = cGVOPx_gv(kUNOP->op_first); + name = GvNAME(gv); + len = GvNAMELEN(gv); name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0; - } - else if (kid->op_type == OP_AELEM - || kid->op_type == OP_HELEM) - { - OP *firstop; - OP *op = ((BINOP*)kid)->op_first; - name = NULL; - if (op) { - SV *tmpstr = NULL; - const char * const a = - kid->op_type == OP_AELEM ? - "[]" : "{}"; - if (((op->op_type == OP_RV2AV) || - (op->op_type == OP_RV2HV)) && - (firstop = ((UNOP*)op)->op_first) && - (firstop->op_type == OP_GV)) { - /* packagevar $a[] or $h{} */ - GV * const gv = cGVOPx_gv(firstop); - if (gv) - tmpstr = - Perl_newSVpvf(aTHX_ - "%s%c...%c", - GvNAME(gv), - a[0], a[1]); - } - else if (op->op_type == OP_PADAV - || op->op_type == OP_PADHV) { - /* lexicalvar $a[] or $h{} */ - const char * const padname = - PAD_COMPNAME_PV(op->op_targ); - if (padname) - tmpstr = - Perl_newSVpvf(aTHX_ - "%s%c...%c", - padname + 1, - a[0], a[1]); - } - if (tmpstr) { - name = SvPV_const(tmpstr, len); + } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + OP *firstop; + OP *op = ((BINOP*)kid)->op_first; + name = NULL; + if (op) { + SV *tmpstr = NULL; + const char * const a = + kid->op_type == OP_AELEM ? + "[]" : "{}"; + if (((op->op_type == OP_RV2AV) || + (op->op_type == OP_RV2HV)) && + (firstop = ((UNOP*)op)->op_first) && + (firstop->op_type == OP_GV)) { + /* packagevar $a[] or $h{} */ + GV * const gv = cGVOPx_gv(firstop); + if (gv) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + GvNAME(gv), + a[0], a[1]); + } + else if (op->op_type == OP_PADAV + || op->op_type == OP_PADHV) { + /* lexicalvar $a[] or $h{} */ + const char * const padname = + PAD_COMPNAME_PV(op->op_targ); + if (padname) + tmpstr = + Perl_newSVpvf(aTHX_ + "%s%c...%c", + padname + 1, + a[0], a[1]); + } + if (tmpstr) { + name = SvPV_const(tmpstr, len); name_utf8 = SvUTF8(tmpstr); - sv_2mortal(tmpstr); - } - } - if (!name) { - name = "__ANONIO__"; - len = 10; - want_dollar = FALSE; - } - op_lvalue(kid, type); - } - if (name) { - SV *namesv; - targ = pad_alloc(OP_RV2GV, SVf_READONLY); - namesv = PAD_SVl(targ); - if (want_dollar && *name != '$') - sv_setpvs(namesv, "$"); - else + sv_2mortal(tmpstr); + } + } + if (!name) { + name = "__ANONIO__"; + len = 10; + want_dollar = FALSE; + } + op_lvalue(kid, type); + } + if (name) { + SV *namesv; + targ = pad_alloc(OP_RV2GV, SVf_READONLY); + namesv = PAD_SVl(targ); + if (want_dollar && *name != '$') + sv_setpvs(namesv, "$"); + else SvPVCLEAR(namesv); - sv_catpvn(namesv, name, len); + sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); - } - } + } + } scalar(kid); kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_RV2GV, flags); kid->op_targ = targ; kid->op_private |= priv; - } - } - scalar(kid); - break; - case OA_SCALARREF: - if ((type == OP_UNDEF || type == OP_POS) - && numargs == 1 && !(oa >> 4) - && kid->op_type == OP_LIST) - return too_many_arguments_pv(o,PL_op_desc[type], 0); - op_lvalue(scalar(kid), type); - break; - } - oa >>= 4; - prev_kid = kid; - kid = OpSIBLING(kid); - } - /* FIXME - should the numargs or-ing move after the too many + } + } + scalar(kid); + break; + case OA_SCALARREF: + if ((type == OP_UNDEF || type == OP_POS) + && numargs == 1 && !(oa >> 4) + && kid->op_type == OP_LIST) + return too_many_arguments_pv(o,PL_op_desc[type], 0); + op_lvalue(scalar(kid), type); + break; + } + oa >>= 4; + prev_kid = kid; + kid = OpSIBLING(kid); + } + /* FIXME - should the numargs or-ing move after the too many * arguments check? */ - o->op_private |= numargs; - if (kid) - return too_many_arguments_pv(o,OP_DESC(o), 0); - listkids(o); + o->op_private |= numargs; + if (kid) + return too_many_arguments_pv(o,OP_DESC(o), 0); + listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { - /* Ordering of these two is important to keep f_map.t passing. */ - op_free(o); - return newUNOP(type, 0, newDEFSVOP()); + /* Ordering of these two is important to keep f_map.t passing. */ + op_free(o); + return newUNOP(type, 0, newDEFSVOP()); } if (oa) { - while (oa & OA_OPTIONAL) - oa >>= 4; - if (oa && oa != OA_LIST) - return too_few_arguments_pv(o,OP_DESC(o), 0); + while (oa & OA_OPTIONAL) + oa >>= 4; + if (oa && oa != OA_LIST) + return too_few_arguments_pv(o,OP_DESC(o), 0); } return o; } @@ -13245,36 +13535,36 @@ Perl_ck_glob(pTHX_ OP *o) o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first)) - op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ + op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) { - /* convert - * glob - * \ null - const(wildcard) - * into - * null - * \ enter - * \ list - * \ mark - glob - rv2cv - * | \ gv(CORE::GLOBAL::glob) - * | - * \ null - const(wildcard) - */ - o->op_flags |= OPf_SPECIAL; - o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); - o = S_new_entersubop(aTHX_ gv, o); - o = newUNOP(OP_NULL, 0, o); - o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ - return o; + /* convert + * glob + * \ null - const(wildcard) + * into + * null + * \ enter + * \ list + * \ mark - glob - rv2cv + * | \ gv(CORE::GLOBAL::glob) + * | + * \ null - const(wildcard) + */ + o->op_flags |= OPf_SPECIAL; + o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); + o = S_new_entersubop(aTHX_ gv, o); + o = newUNOP(OP_NULL, 0, o); + o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ + return o; } else o->op_flags &= ~OPf_SPECIAL; #if !defined(PERL_EXTERNAL_GLOB) if (!PL_globhook) { - ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs("File::Glob"), NULL, NULL, NULL); - LEAVE; + ENTER; + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvs("File::Glob"), NULL, NULL, NULL); + LEAVE; } #endif /* !PERL_EXTERNAL_GLOB */ gv = (GV *)newSV(0); @@ -13298,22 +13588,22 @@ Perl_ck_grep(pTHX_ OP *o) /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { - kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; - if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) - return no_fh_allowed(o); - o->op_flags &= ~OPf_STACKED; + kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first; + if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) + return no_fh_allowed(o); + o->op_flags &= ~OPf_STACKED; } kid = OpSIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) - list(kid); + list(kid); else - scalar(kid); + scalar(kid); o = ck_fun(o); if (PL_parser && PL_parser->error_count) - return o; + return o; kid = OpSIBLING(cLISTOPo->op_first); if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); + Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; gwop = alloc_LOGOP(type, o, LINKLIST(kid)); @@ -13323,7 +13613,7 @@ Perl_ck_grep(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) - op_lvalue(kid, OP_GREPSTART); + op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; } @@ -13334,26 +13624,26 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ - if (kid) - kid = OpSIBLING(kid); /* get past "big" */ - if (kid && kid->op_type == OP_CONST) { - const bool save_taint = TAINT_get; - SV *sv = kSVOP->op_sv; - if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) + OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid) + kid = OpSIBLING(kid); /* get past "big" */ + if (kid && kid->op_type == OP_CONST) { + const bool save_taint = TAINT_get; + SV *sv = kSVOP->op_sv; + if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv)) && SvOK(sv) && !SvROK(sv)) { - sv = newSV(0); - sv_copypv(sv, kSVOP->op_sv); - SvREFCNT_dec_NN(kSVOP->op_sv); - kSVOP->op_sv = sv; - } - if (SvOK(sv)) fbm_compile(sv, 0); - TAINT_set(save_taint); + sv = newSV(0); + sv_copypv(sv, kSVOP->op_sv); + SvREFCNT_dec_NN(kSVOP->op_sv); + kSVOP->op_sv = sv; + } + if (SvOK(sv)) fbm_compile(sv, 0); + TAINT_set(save_taint); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(save_taint); #endif - } + } } return ck_fun(o); } @@ -13374,23 +13664,23 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ PERL_ARGS_ASSERT_CK_DEFINED; if ((o->op_flags & OPf_KIDS)) { - switch (cUNOPo->op_first->op_type) { - case OP_RV2AV: - case OP_PADAV: - Perl_croak(aTHX_ "Can't use 'defined(@array)'" - " (Maybe you should just omit the defined()?)"); + switch (cUNOPo->op_first->op_type) { + case OP_RV2AV: + case OP_PADAV: + Perl_croak(aTHX_ "Can't use 'defined(@array)'" + " (Maybe you should just omit the defined()?)"); NOT_REACHED; /* NOTREACHED */ break; - case OP_RV2HV: - case OP_PADHV: - Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" - " (Maybe you should just omit the defined()?)"); + case OP_RV2HV: + case OP_PADHV: + Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" + " (Maybe you should just omit the defined()?)"); NOT_REACHED; /* NOTREACHED */ - break; - default: - /* no warning */ - break; - } + break; + default: + /* no warning */ + break; + } } return ck_rfun(o); } @@ -13401,15 +13691,15 @@ Perl_ck_readline(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_READLINE; if (o->op_flags & OPf_KIDS) { - OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; scalar(kid); } else { - OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); - op_free(o); - return newop; + OP * const newop + = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + op_free(o); + return newop; } return o; } @@ -13433,27 +13723,27 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; if (!kid) { - o = force_list(o, 1); - kid = cLISTOPo->op_first; + o = force_list(o, TRUE); + kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = OpSIBLING(kid); + kid = OpSIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = OpSIBLING(kid); + kid = OpSIBLING(kid); else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */ - if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE - && !kid->op_folded) { - o->op_flags |= OPf_STACKED; /* make it a filehandle */ + if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE + && !kid->op_folded) { + o->op_flags |= OPf_STACKED; /* make it a filehandle */ scalar(kid); /* replace old const op with new OP_RV2GV parent */ kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, OP_RV2GV, OPf_REF); kid = OpSIBLING(kid); - } + } } if (!kid) - op_append_elem(o->op_type, o, newDEFSVOP()); + op_append_elem(o->op_type, o, newDEFSVOP()); if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); return listkids(o); @@ -13462,29 +13752,28 @@ Perl_ck_listiob(pTHX_ OP *o) OP * Perl_ck_smartmatch(pTHX_ OP *o) { - dVAR; PERL_ARGS_ASSERT_CK_SMARTMATCH; if (0 == (o->op_flags & OPf_SPECIAL)) { - OP *first = cBINOPo->op_first; - OP *second = OpSIBLING(first); + OP *first = cBINOPo->op_first; + OP *second = OpSIBLING(first); - /* Implicitly take a reference to an array or hash */ + /* Implicitly take a reference to an array or hash */ /* remove the original two siblings, then add back the * (possibly different) first and second sibs. */ op_sibling_splice(o, NULL, 1, NULL); op_sibling_splice(o, NULL, 1, NULL); - first = ref_array_or_hash(first); - second = ref_array_or_hash(second); + first = ref_array_or_hash(first); + second = ref_array_or_hash(second); op_sibling_splice(o, NULL, 0, second); op_sibling_splice(o, NULL, 0, first); - /* Implicitly take a reference to a regular expression */ - if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { + /* Implicitly take a reference to a regular expression */ + if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { OpTYPE_set(first, OP_QR); - } - if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { + } + if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { OpTYPE_set(second, OP_QR); } } @@ -13499,27 +13788,27 @@ S_maybe_targlex(pTHX_ OP *o) OP * const kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) - && !(kid->op_flags & OPf_STACKED) - /* Cannot steal the second time! */ - && !(kid->op_private & OPpTARGET_MY) - ) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY) + ) { - OP * const kkid = OpSIBLING(kid); - - /* Can just relocate the target. */ - if (kkid && kkid->op_type == OP_PADSV - && (!(kkid->op_private & OPpLVAL_INTRO) - || kkid->op_private & OPpPAD_STATE)) - { - kid->op_targ = kkid->op_targ; - kkid->op_targ = 0; - /* Now we do not need PADSV and SASSIGN. - * Detach kid and free the rest. */ - op_sibling_splice(o, NULL, 1, NULL); - op_free(o); - kid->op_private |= OPpTARGET_MY; /* Used for context settings */ - return kid; - } + OP * const kkid = OpSIBLING(kid); + + /* Can just relocate the target. */ + if (kkid && kkid->op_type == OP_PADSV + && (!(kkid->op_private & OPpLVAL_INTRO) + || kkid->op_private & OPpPAD_STATE)) + { + kid->op_targ = kkid->op_targ; + kkid->op_targ = 0; + /* Now we do not need PADSV and SASSIGN. + * Detach kid and free the rest. */ + op_sibling_splice(o, NULL, 1, NULL); + op_free(o); + kid->op_private |= OPpTARGET_MY; /* Used for context settings */ + return kid; + } } return o; } @@ -13527,24 +13816,23 @@ S_maybe_targlex(pTHX_ OP *o) OP * Perl_ck_sassign(pTHX_ OP *o) { - dVAR; OP * const kid = cBINOPo->op_first; PERL_ARGS_ASSERT_CK_SASSIGN; if (OpHAS_SIBLING(kid)) { - OP *kkid = OpSIBLING(kid); - /* For state variable assignment with attributes, kkid is a list op - whose op_last is a padsv. */ - if ((kkid->op_type == OP_PADSV || - (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && - (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV - ) - ) - && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) - == (OPpLVAL_INTRO|OPpPAD_STATE)) { - return S_newONCEOP(aTHX_ o, kkid); - } + OP *kkid = OpSIBLING(kid); + /* For state variable assignment with attributes, kkid is a list op + whose op_last is a padsv. */ + if ((kkid->op_type == OP_PADSV || + (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && + (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV + ) + ) + && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) + == (OPpLVAL_INTRO|OPpPAD_STATE)) { + return S_newONCEOP(aTHX_ o, kkid); + } } return S_maybe_targlex(aTHX_ o); } @@ -13636,24 +13924,24 @@ Perl_ck_open(pTHX_ OP *o) S_io_hints(aTHX_ o); { - /* In case of three-arg dup open remove strictness - * from the last arg if it is a bareword. */ - OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ - OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ - OP *oa; - const char *mode; - - if ((last->op_type == OP_CONST) && /* The bareword. */ - (last->op_private & OPpCONST_BARE) && - (last->op_private & OPpCONST_STRICT) && - (oa = OpSIBLING(first)) && /* The fh. */ - (oa = OpSIBLING(oa)) && /* The mode. */ - (oa->op_type == OP_CONST) && - SvPOK(((SVOP*)oa)->op_sv) && - (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && - mode[0] == '>' && mode[1] == '&' && /* A dup open. */ - (last == OpSIBLING(oa))) /* The bareword. */ - last->op_private &= ~OPpCONST_STRICT; + /* In case of three-arg dup open remove strictness + * from the last arg if it is a bareword. */ + OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */ + OP * const last = cLISTOPx(o)->op_last; /* The bareword. */ + OP *oa; + const char *mode; + + if ((last->op_type == OP_CONST) && /* The bareword. */ + (last->op_private & OPpCONST_BARE) && + (last->op_private & OPpCONST_STRICT) && + (oa = OpSIBLING(first)) && /* The fh. */ + (oa = OpSIBLING(oa)) && /* The mode. */ + (oa->op_type == OP_CONST) && + SvPOK(((SVOP*)oa)->op_sv) && + (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && + mode[0] == '>' && mode[1] == '&' && /* A dup open. */ + (last == OpSIBLING(oa))) /* The bareword. */ + last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); } @@ -13663,8 +13951,8 @@ Perl_ck_prototype(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_PROTOTYPE; if (!(o->op_flags & OPf_KIDS)) { - op_free(o); - return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); + op_free(o); + return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP()); } return o; } @@ -13689,43 +13977,43 @@ Perl_ck_refassign(pTHX_ OP *o) switch (varop->op_type) { case OP_PADAV: - o->op_private |= OPpLVREF_AV; - goto settarg; + o->op_private |= OPpLVREF_AV; + goto settarg; case OP_PADHV: - o->op_private |= OPpLVREF_HV; + o->op_private |= OPpLVREF_HV; /* FALLTHROUGH */ case OP_PADSV: settarg: o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)); - o->op_targ = varop->op_targ; - varop->op_targ = 0; - PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); - break; + o->op_targ = varop->op_targ; + varop->op_targ = 0; + PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX); + break; case OP_RV2AV: - o->op_private |= OPpLVREF_AV; - goto checkgv; + o->op_private |= OPpLVREF_AV; + goto checkgv; NOT_REACHED; /* NOTREACHED */ case OP_RV2HV: - o->op_private |= OPpLVREF_HV; + o->op_private |= OPpLVREF_HV; /* FALLTHROUGH */ case OP_RV2SV: checkgv: o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)); - if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; + if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad; detach_and_stack: - /* Point varop to its GV kid, detached. */ - varop = op_sibling_splice(varop, NULL, -1, NULL); - stacked = TRUE; - break; + /* Point varop to its GV kid, detached. */ + varop = op_sibling_splice(varop, NULL, -1, NULL); + stacked = TRUE; + break; case OP_RV2CV: { - OP * const kidparent = - OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); - OP * const kid = cUNOPx(kidparent)->op_first; - o->op_private |= OPpLVREF_CV; - if (kid->op_type == OP_GV) { + OP * const kidparent = + OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first); + OP * const kid = cUNOPx(kidparent)->op_first; + o->op_private |= OPpLVREF_CV; + if (kid->op_type == OP_GV) { SV *sv = (SV*)cGVOPx_gv(kid); - varop = kidparent; + varop = kidparent; if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { /* a CVREF here confuses pp_refassign, so make sure it gets a GV */ @@ -13734,43 +14022,43 @@ Perl_ck_refassign(pTHX_ OP *o) (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0); assert(SvTYPE(sv) == SVt_PVGV); } - goto detach_and_stack; - } - if (kid->op_type != OP_PADCV) goto bad; - o->op_targ = kid->op_targ; - kid->op_targ = 0; - break; + goto detach_and_stack; + } + if (kid->op_type != OP_PADCV) goto bad; + o->op_targ = kid->op_targ; + kid->op_targ = 0; + break; } case OP_AELEM: case OP_HELEM: o->op_private |= (varop->op_private & OPpLVAL_INTRO); - o->op_private |= OPpLVREF_ELEM; - op_null(varop); - stacked = TRUE; - /* Detach varop. */ - op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); - break; + o->op_private |= OPpLVREF_ELEM; + op_null(varop); + stacked = TRUE; + /* Detach varop. */ + op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL); + break; default: bad: - /* diag_listed_as: Can't modify reference to %s in %s assignment */ - yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " - "assignment", - OP_DESC(varop))); - return o; + /* diag_listed_as: Can't modify reference to %s in %s assignment */ + yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar " + "assignment", + OP_DESC(varop))); + return o; } if (!FEATURE_REFALIASING_IS_ENABLED) - Perl_croak(aTHX_ - "Experimental aliasing via reference not enabled"); + Perl_croak(aTHX_ + "Experimental aliasing via reference not enabled"); Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__REFALIASING), - "Aliasing via reference is experimental"); + packWARN(WARN_EXPERIMENTAL__REFALIASING), + "Aliasing via reference is experimental"); if (stacked) { - o->op_flags |= OPf_STACKED; - op_sibling_splice(o, right, 1, varop); + o->op_flags |= OPf_STACKED; + op_sibling_splice(o, right, 1, varop); } else { - o->op_flags &=~ OPf_STACKED; - op_sibling_splice(o, right, 1, NULL); + o->op_flags &=~ OPf_STACKED; + op_sibling_splice(o, right, 1, NULL); } op_free(left); return o; @@ -13783,13 +14071,13 @@ Perl_ck_repeat(pTHX_ OP *o) if (cBINOPo->op_first->op_flags & OPf_PARENS) { OP* kids; - o->op_private |= OPpREPEAT_DOLIST; + o->op_private |= OPpREPEAT_DOLIST; kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */ - kids = force_list(kids, 1); /* promote it to a list */ + kids = force_list(kids, TRUE); /* promote it to a list */ op_sibling_splice(o, NULL, 0, kids); /* and add back */ } else - scalar(o); + scalar(o); return o; } @@ -13801,88 +14089,86 @@ Perl_ck_require(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_REQUIRE; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ - SVOP * const kid = (SVOP*)cUNOPo->op_first; - U32 hash; - char *s; - STRLEN len; - if (kid->op_type == OP_CONST) { - SV * const sv = kid->op_sv; - U32 const was_readonly = SvREADONLY(sv); - if (kid->op_private & OPpCONST_BARE) { - dVAR; - const char *end; + SVOP * const kid = (SVOP*)cUNOPo->op_first; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + const char *end; HEK *hek; - if (was_readonly) { + if (was_readonly) { SvREADONLY_off(sv); } - if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); - s = SvPVX(sv); - len = SvCUR(sv); - end = s + len; + s = SvPVX(sv); + len = SvCUR(sv); + end = s + len; /* treat ::foo::bar as foo::bar */ if (len >= 2 && s[0] == ':' && s[1] == ':') DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); if (s == end) DIE(aTHX_ "Bareword in require maps to empty filename"); - for (; s < end; s++) { - if (*s == ':' && s[1] == ':') { - *s = '/'; - Move(s+2, s+1, end - s - 1, char); - --end; - } - } - SvEND_set(sv, end); - sv_catpvs(sv, ".pm"); - PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); - hek = share_hek(SvPVX(sv), - (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), - hash); - sv_sethek(sv, hek); - unshare_hek(hek); - SvFLAGS(sv) |= was_readonly; - } - else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv) - && !SvVOK(sv)) { - s = SvPV(sv, len); - if (SvREFCNT(sv) > 1) { - kid->op_sv = newSVpvn_share( - s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); - SvREFCNT_dec_NN(sv); - } - else { - dVAR; + for (; s < end; s++) { + if (*s == ':' && s[1] == ':') { + *s = '/'; + Move(s+2, s+1, end - s - 1, char); + --end; + } + } + SvEND_set(sv, end); + sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv) + && !SvVOK(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { HEK *hek; - if (was_readonly) SvREADONLY_off(sv); - PERL_HASH(hash, s, len); - hek = share_hek(s, - SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, - hash); - sv_sethek(sv, hek); - unshare_hek(hek); - SvFLAGS(sv) |= was_readonly; - } - } - } + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } + } } if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */ - /* handle override, if any */ + /* handle override, if any */ && (gv = gv_override("require", 7))) { - OP *kid, *newop; - if (o->op_flags & OPf_KIDS) { - kid = cUNOPo->op_first; + OP *kid, *newop; + if (o->op_flags & OPf_KIDS) { + kid = cUNOPo->op_first; op_sibling_splice(o, NULL, -1, NULL); - } - else { - kid = newDEFSVOP(); - } - op_free(o); - newop = S_new_entersubop(aTHX_ gv, kid); - return newop; + } + else { + kid = newDEFSVOP(); + } + op_free(o); + newop = S_new_entersubop(aTHX_ gv, kid); + return newop; } return ck_fun(o); @@ -13897,8 +14183,8 @@ Perl_ck_return(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); if (PL_compcv && CvLVALUE(PL_compcv)) { - for (; kid; kid = OpSIBLING(kid)) - op_lvalue(kid, OP_LEAVESUBLV); + for (; kid; kid = OpSIBLING(kid)) + op_lvalue(kid, OP_LEAVESUBLV); } return o; @@ -13907,7 +14193,6 @@ Perl_ck_return(pTHX_ OP *o) OP * Perl_ck_select(pTHX_ OP *o) { - dVAR; OP* kid; PERL_ARGS_ASSERT_CK_SELECT; @@ -13916,14 +14201,14 @@ Perl_ck_select(pTHX_ OP *o) kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && OpHAS_SIBLING(kid)) { OpTYPE_set(o, OP_SSELECT); - o = ck_fun(o); - return fold_constants(op_integerize(op_std_init(o))); - } + o = ck_fun(o); + return fold_constants(op_integerize(op_std_init(o))); + } } o = ck_fun(o); kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) - kid->op_private &= ~HINT_STRICT_REFS; + kid->op_private &= ~HINT_STRICT_REFS; return o; } @@ -13935,16 +14220,16 @@ Perl_ck_shift(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { - OP *argop; + OP *argop; - if (!CvUNIQUE(PL_compcv)) { - o->op_flags |= OPf_SPECIAL; - return o; - } + if (!CvUNIQUE(PL_compcv)) { + o->op_flags |= OPf_SPECIAL; + return o; + } - argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); - op_free(o); - return newUNOP(type, 0, scalar(argop)); + argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); + op_free(o); + return newUNOP(type, 0, scalar(argop)); } return scalar(ck_fun(o)); } @@ -13954,81 +14239,71 @@ Perl_ck_sort(pTHX_ OP *o) { OP *firstkid; OP *kid; - HV * const hinthv = - PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL; U8 stacked; PERL_ARGS_ASSERT_CK_SORT; - if (hinthv) { - SV ** const svp = hv_fetchs(hinthv, "sort", FALSE); - if (svp) { - const I32 sorthints = (I32)SvIV(*svp); - if ((sorthints & HINT_SORT_STABLE) != 0) - o->op_private |= OPpSORT_STABLE; - if ((sorthints & HINT_SORT_UNSTABLE) != 0) - o->op_private |= OPpSORT_UNSTABLE; - } - } - if (o->op_flags & OPf_STACKED) - simplify_sort(o); + simplify_sort(o); firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (!firstkid) + return too_few_arguments_pv(o,OP_DESC(o), 0); + if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ - OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ /* if the first arg is a code block, process it and mark sort as * OPf_SPECIAL */ - if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { - LINKLIST(kid); - if (kid->op_type == OP_LEAVE) - op_null(kid); /* wipe out leave */ - /* Prevent execution from escaping out of the sort block. */ - kid->op_next = 0; - - /* provide scalar context for comparison function/block */ - kid = scalar(firstkid); - kid->op_next = kid; - o->op_flags |= OPf_SPECIAL; - } - else if (kid->op_type == OP_CONST - && kid->op_private & OPpCONST_BARE) { - char tmpbuf[256]; - STRLEN len; - PADOFFSET off; - const char * const name = SvPV(kSVOP_sv, len); - *tmpbuf = '&'; - assert (len < 256); - Copy(name, tmpbuf+1, len, char); - off = pad_findmy_pvn(tmpbuf, len+1, 0); - if (off != NOT_IN_PAD) { - if (PAD_COMPNAME_FLAGS_isOUR(off)) { - SV * const fq = - newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); - sv_catpvs(fq, "::"); - sv_catsv(fq, kSVOP_sv); - SvREFCNT_dec_NN(kSVOP_sv); - kSVOP->op_sv = fq; - } - else { - OP * const padop = newOP(OP_PADCV, 0); - padop->op_targ = off; + if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { + LINKLIST(kid); + if (kid->op_type == OP_LEAVE) + op_null(kid); /* wipe out leave */ + /* Prevent execution from escaping out of the sort block. */ + kid->op_next = 0; + + /* provide scalar context for comparison function/block */ + kid = scalar(firstkid); + kid->op_next = kid; + o->op_flags |= OPf_SPECIAL; + } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, 0); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; /* replace the const op with the pad op */ op_sibling_splice(firstkid, NULL, 1, padop); - op_free(kid); - } - } - } + op_free(kid); + } + } + } - firstkid = OpSIBLING(firstkid); + firstkid = OpSIBLING(firstkid); } for (kid = firstkid; kid; kid = OpSIBLING(kid)) { - /* provide list context for arguments */ - list(kid); - if (stacked) - op_lvalue(kid, OP_GREPSTART); + /* provide list context for arguments */ + list(kid); + if (stacked) + op_lvalue(kid, OP_GREPSTART); } return o; @@ -14038,9 +14313,9 @@ Perl_ck_sort(pTHX_ OP *o) * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a * elide the second child of the sort (the one containing X), * and set these flags as appropriate - OPpSORT_NUMERIC; - OPpSORT_INTEGER; - OPpSORT_DESCEND; + OPpSORT_NUMERIC; + OPpSORT_INTEGER; + OPpSORT_DESCEND; * Also, check and warn on lexical $a, $b. */ @@ -14059,87 +14334,87 @@ S_simplify_sort(pTHX_ OP *o) kid = kUNOP->op_first; /* get past null */ if (!(have_scopeop = kid->op_type == OP_SCOPE) && kid->op_type != OP_LEAVE) - return; + return; kid = kLISTOP->op_last; /* get past scope */ switch(kid->op_type) { - case OP_NCMP: - case OP_I_NCMP: - case OP_SCMP: - if (!have_scopeop) goto padkids; - break; - default: - return; + case OP_NCMP: + case OP_I_NCMP: + case OP_SCMP: + if (!have_scopeop) goto padkids; + break; + default: + return; } k = kid; /* remember this node*/ if (kBINOP->op_first->op_type != OP_RV2SV || kBINOP->op_last ->op_type != OP_RV2SV) { - /* - Warn about my($a) or my($b) in a sort block, *if* $a or $b is - then used in a comparison. This catches most, but not - all cases. For instance, it catches - sort { my($a); $a <=> $b } - but not - sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } - (although why you'd do that is anyone's guess). - */ + /* + Warn about my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ padkids: - if (!ckWARN(WARN_SYNTAX)) return; - kid = kBINOP->op_first; - do { - if (kid->op_type == OP_PADSV) { - PADNAME * const name = PAD_COMPNAME(kid->op_targ); - if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' - && ( PadnamePV(name)[1] == 'a' - || PadnamePV(name)[1] == 'b' )) - /* diag_listed_as: "my %s" used in sort comparison */ - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\"%s %s\" used in sort comparison", - PadnameIsSTATE(name) - ? "state" - : "my", - PadnamePV(name)); - } - } while ((kid = OpSIBLING(kid))); - return; + if (!ckWARN(WARN_SYNTAX)) return; + kid = kBINOP->op_first; + do { + if (kid->op_type == OP_PADSV) { + PADNAME * const name = PAD_COMPNAME(kid->op_targ); + if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$' + && ( PadnamePV(name)[1] == 'a' + || PadnamePV(name)[1] == 'b' )) + /* diag_listed_as: "my %s" used in sort comparison */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\"%s %s\" used in sort comparison", + PadnameIsSTATE(name) + ? "state" + : "my", + PadnamePV(name)); + } + } while ((kid = OpSIBLING(kid))); + return; } kid = kBINOP->op_first; /* get past cmp */ if (kUNOP->op_first->op_type != OP_GV) - return; + return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) - return; + return; gvname = GvNAME(gv); if (*gvname == 'a' && gvname[1] == '\0') - descending = 0; + descending = 0; else if (*gvname == 'b' && gvname[1] == '\0') - descending = 1; + descending = 1; else - return; + return; kid = k; /* back to cmp */ /* already checked above that it is rv2sv */ kid = kBINOP->op_last; /* down to 2nd arg */ if (kUNOP->op_first->op_type != OP_GV) - return; + return; kid = kUNOP->op_first; /* get past rv2sv */ gv = kGVOP_gv; if (GvSTASH(gv) != PL_curstash) - return; + return; gvname = GvNAME(gv); if ( descending - ? !(*gvname == 'a' && gvname[1] == '\0') - : !(*gvname == 'b' && gvname[1] == '\0')) - return; + ? !(*gvname == 'a' && gvname[1] == '\0') + : !(*gvname == 'b' && gvname[1] == '\0')) + return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (descending) - o->op_private |= OPpSORT_DESCEND; + o->op_private |= OPpSORT_DESCEND; if (k->op_type == OP_NCMP) - o->op_private |= OPpSORT_NUMERIC; + o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) - o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; + o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; kid = OpSIBLING(cLISTOPo->op_first); /* cut out and delete old block (second sibling) */ op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); @@ -14149,7 +14424,6 @@ S_simplify_sort(pTHX_ OP *o) OP * Perl_ck_split(pTHX_ OP *o) { - dVAR; OP *kid; OP *sibs; @@ -14158,13 +14432,13 @@ Perl_ck_split(pTHX_ OP *o) assert(o->op_type == OP_LIST); if (o->op_flags & OPf_STACKED) - return no_fh_allowed(o); + return no_fh_allowed(o); kid = cLISTOPo->op_first; /* delete leading NULL node, then add a CONST if no other nodes */ assert(kid->op_type == OP_NULL); op_sibling_splice(o, NULL, 1, - OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); + OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); op_free(kid); kid = cLISTOPo->op_first; @@ -14181,7 +14455,7 @@ Perl_ck_split(pTHX_ OP *o) if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /g modifier is meaningless in split"); + "Use of /g modifier is meaningless in split"); } /* eliminate the split op, and move the match op (plus any children) @@ -14209,21 +14483,21 @@ Perl_ck_split(pTHX_ OP *o) kid = sibs; /* kid is now the string arg of the split */ if (!kid) { - kid = newDEFSVOP(); - op_append_elem(OP_SPLIT, o, kid); + kid = newDEFSVOP(); + op_append_elem(OP_SPLIT, o, kid); } scalar(kid); kid = OpSIBLING(kid); if (!kid) { kid = newSVOP(OP_CONST, 0, newSViv(0)); - op_append_elem(OP_SPLIT, o, kid); - o->op_private |= OPpSPLIT_IMPLIM; + op_append_elem(OP_SPLIT, o, kid); + o->op_private |= OPpSPLIT_IMPLIM; } scalar(kid); if (OpHAS_SIBLING(kid)) - return too_many_arguments_pv(o,OP_DESC(o), 0); + return too_many_arguments_pv(o,OP_DESC(o), 0); return o; } @@ -14236,11 +14510,11 @@ Perl_ck_stringify(pTHX_ OP *o) if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST) - && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ + && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */ { - op_sibling_splice(o, cUNOPo->op_first, -1, NULL); - op_free(o); - return kid; + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + op_free(o); + return kid; } return ck_fun(o); } @@ -14253,32 +14527,32 @@ Perl_ck_join(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_JOIN; if (kid && kid->op_type == OP_MATCH) { - if (ckWARN(WARN_SYNTAX)) { + if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const SV *msg = re ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re), SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) : newSVpvs_flags( "STRING", SVs_TEMP ); - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%" SVf "/ should probably be written as \"%" SVf "\"", - SVfARG(msg), SVfARG(msg)); - } + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "/%" SVf "/ should probably be written as \"%" SVf "\"", + SVfARG(msg), SVfARG(msg)); + } } if (kid && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */ - || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) - || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV - && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) + || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO)) + || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV + && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))) { - const OP * const bairn = OpSIBLING(kid); /* the list */ - if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ - && OP_GIMME(bairn,0) == G_SCALAR) - { - OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, - op_sibling_splice(o, kid, 1, NULL)); - op_free(o); - return ret; - } + const OP * const bairn = OpSIBLING(kid); /* the list */ + if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */ + && OP_GIMME(bairn,0) == G_SCALAR) + { + OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED, + op_sibling_splice(o, kid, 1, NULL)); + op_free(o); + return ret; + } } return ck_fun(o); @@ -14335,14 +14609,14 @@ Perl_find_lexical_cv(pTHX_ PADOFFSET off) PADNAME *name = PAD_COMPNAME(off); CV *compcv = PL_compcv; while (PadnameOUTER(name)) { - assert(PARENT_PAD_INDEX(name)); - compcv = CvOUTSIDE(compcv); - name = PadlistNAMESARRAY(CvPADLIST(compcv)) - [off = PARENT_PAD_INDEX(name)]; + assert(PARENT_PAD_INDEX(name)); + compcv = CvOUTSIDE(compcv); + name = PadlistNAMESARRAY(CvPADLIST(compcv)) + [off = PARENT_PAD_INDEX(name)]; } assert(!PadnameIsOUR(name)); if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) { - return PadnamePROTOCV(name); + return PadnamePROTOCV(name); } return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; } @@ -14355,65 +14629,65 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; if (flags & ~RV2CVOPCV_FLAG_MASK) - Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); + Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) - return NULL; + return NULL; if (cvop->op_private & OPpENTERSUB_AMPER) - return NULL; + return NULL; if (!(cvop->op_flags & OPf_KIDS)) - return NULL; + return NULL; rvop = cUNOPx(cvop)->op_first; switch (rvop->op_type) { - case OP_GV: { - gv = cGVOPx_gv(rvop); - if (!isGV(gv)) { - if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { - cv = MUTABLE_CV(SvRV(gv)); - gv = NULL; - break; - } - if (flags & RV2CVOPCV_RETURN_STUB) - return (CV *)gv; - else return NULL; - } - cv = GvCVu(gv); - if (!cv) { - if (flags & RV2CVOPCV_MARK_EARLY) - rvop->op_private |= OPpEARLY_CV; - return NULL; - } - } break; - case OP_CONST: { - SV *rv = cSVOPx_sv(rvop); - if (!SvROK(rv)) - return NULL; - cv = (CV*)SvRV(rv); - gv = NULL; - } break; - case OP_PADCV: { - cv = find_lexical_cv(rvop->op_targ); - gv = NULL; - } break; - default: { - return NULL; - } NOT_REACHED; /* NOTREACHED */ + case OP_GV: { + gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } + cv = GvCVu(gv); + if (!cv) { + if (flags & RV2CVOPCV_MARK_EARLY) + rvop->op_private |= OPpEARLY_CV; + return NULL; + } + } break; + case OP_CONST: { + SV *rv = cSVOPx_sv(rvop); + if (!SvROK(rv)) + return NULL; + cv = (CV*)SvRV(rv); + gv = NULL; + } break; + case OP_PADCV: { + cv = find_lexical_cv(rvop->op_targ); + gv = NULL; + } break; + default: { + return NULL; + } NOT_REACHED; /* NOTREACHED */ } if (SvTYPE((SV*)cv) != SVt_PVCV) - return NULL; + return NULL; if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) - gv = CvGV(cv); - return (CV*)gv; + if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) + gv = CvGV(cv); + return (CV*)gv; } else if (flags & RV2CVOPCV_MAYBE_NAME_GV) { - if (CvLEXICAL(cv) || CvNAMED(cv)) - return NULL; - if (!CvANON(cv) || !gv) - gv = CvGV(cv); - return (CV*)gv; + if (CvLEXICAL(cv) || CvNAMED(cv)) + return NULL; + if (!CvANON(cv) || !gv) + gv = CvGV(cv); + return (CV*)gv; } else { - return cv; + return cv; } } @@ -14439,7 +14713,7 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { /* skip the extra attributes->import() call implicitly added in * something like foo(my $x : bar) @@ -14494,10 +14768,10 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *e = NULL; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) - Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " - "flags=%lx", (unsigned long) SvFLAGS(protosv)); + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); if (SvTYPE(protosv) == SVt_PVCV) - proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); + proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; @@ -14505,199 +14779,199 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) { parent = aop; - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; } prev = aop; aop = OpSIBLING(aop); for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; while (aop != cvop) { - OP* o3 = aop; - - if (proto >= proto_end) - { - SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); - return entersubop; - } - - switch (*proto) { - case ';': - optional = 1; - proto++; - continue; - case '_': - /* _ must be at the end */ - if (proto[1] && !memCHRs(";@%", proto[1])) - goto oops; + OP* o3 = aop; + + if (proto >= proto_end) + { + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } + + switch (*proto) { + case ';': + optional = 1; + proto++; + continue; + case '_': + /* _ must be at the end */ + if (proto[1] && !memCHRs(";@%", proto[1])) + goto oops; /* FALLTHROUGH */ - case '$': - proto++; - arg++; - scalar(aop); - break; - case '%': - case '@': - list(aop); - arg++; - break; - case '&': - proto++; - arg++; - if ( o3->op_type != OP_UNDEF + case '$': + proto++; + arg++; + scalar(aop); + break; + case '%': + case '@': + list(aop); + arg++; + break; + case '&': + proto++; + arg++; + if ( o3->op_type != OP_UNDEF && (o3->op_type != OP_SREFGEN || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_ANONCODE && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type != OP_RV2CV))) - bad_type_gv(arg, namegv, o3, - arg == 1 ? "block or sub {}" : "sub {}"); - break; - case '*': - /* '*' allows any scalar type, including bareword */ - proto++; - arg++; - if (o3->op_type == OP_RV2GV) - goto wrapref; /* autoconvert GLOB -> GLOBref */ - else if (o3->op_type == OP_CONST) - o3->op_private &= ~OPpCONST_STRICT; - scalar(aop); - break; - case '+': - proto++; - arg++; - if (o3->op_type == OP_RV2AV || - o3->op_type == OP_PADAV || - o3->op_type == OP_RV2HV || - o3->op_type == OP_PADHV - ) { - goto wrapref; - } - scalar(aop); - break; - case '[': case ']': - goto oops; - - case '\\': - proto++; - arg++; - again: - switch (*proto++) { - case '[': - if (contextclass++ == 0) { - e = (char *) memchr(proto, ']', proto_end - proto); - if (!e || e == proto) - goto oops; - } - else - goto oops; - goto again; - - case ']': - if (contextclass) { - const char *p = proto; - const char *const end = proto; - contextclass = 0; - while (*--p != '[') - /* \[$] accepts any scalar lvalue */ - if (*p == '$' - && Perl_op_lvalue_flags(aTHX_ - scalar(o3), - OP_READ, /* not entersub */ - OP_LVALUE_NO_CROAK - )) goto wrapref; - bad_type_gv(arg, namegv, o3, - Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); - } else - goto oops; - break; - case '*': - if (o3->op_type == OP_RV2GV) - goto wrapref; - if (!contextclass) - bad_type_gv(arg, namegv, o3, "symbol"); - break; - case '&': - if (o3->op_type == OP_ENTERSUB - && !(o3->op_flags & OPf_STACKED)) - goto wrapref; - if (!contextclass) - bad_type_gv(arg, namegv, o3, "subroutine"); - break; - case '$': - if (o3->op_type == OP_RV2SV || - o3->op_type == OP_PADSV || - o3->op_type == OP_HELEM || - o3->op_type == OP_AELEM) - goto wrapref; - if (!contextclass) { - /* \$ accepts any scalar lvalue */ - if (Perl_op_lvalue_flags(aTHX_ - scalar(o3), - OP_READ, /* not entersub */ - OP_LVALUE_NO_CROAK - )) goto wrapref; - bad_type_gv(arg, namegv, o3, "scalar"); - } - break; - case '@': - if (o3->op_type == OP_RV2AV || - o3->op_type == OP_PADAV) - { - o3->op_flags &=~ OPf_PARENS; - goto wrapref; - } - if (!contextclass) - bad_type_gv(arg, namegv, o3, "array"); - break; - case '%': - if (o3->op_type == OP_RV2HV || - o3->op_type == OP_PADHV) - { - o3->op_flags &=~ OPf_PARENS; - goto wrapref; - } - if (!contextclass) - bad_type_gv(arg, namegv, o3, "hash"); - break; - wrapref: + bad_type_gv(arg, namegv, o3, + arg == 1 ? "block or sub {}" : "sub {}"); + break; + case '*': + /* '*' allows any scalar type, including bareword */ + proto++; + arg++; + if (o3->op_type == OP_RV2GV) + goto wrapref; /* autoconvert GLOB -> GLOBref */ + else if (o3->op_type == OP_CONST) + o3->op_private &= ~OPpCONST_STRICT; + scalar(aop); + break; + case '+': + proto++; + arg++; + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV || + o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV + ) { + goto wrapref; + } + scalar(aop); + break; + case '[': case ']': + goto oops; + + case '\\': + proto++; + arg++; + again: + switch (*proto++) { + case '[': + if (contextclass++ == 0) { + e = (char *) memchr(proto, ']', proto_end - proto); + if (!e || e == proto) + goto oops; + } + else + goto oops; + goto again; + + case ']': + if (contextclass) { + const char *p = proto; + const char *const end = proto; + contextclass = 0; + while (*--p != '[') + /* \[$] accepts any scalar lvalue */ + if (*p == '$' + && Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, + Perl_form(aTHX_ "one of %.*s",(int)(end - p), p)); + } else + goto oops; + break; + case '*': + if (o3->op_type == OP_RV2GV) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "symbol"); + break; + case '&': + if (o3->op_type == OP_ENTERSUB + && !(o3->op_flags & OPf_STACKED)) + goto wrapref; + if (!contextclass) + bad_type_gv(arg, namegv, o3, "subroutine"); + break; + case '$': + if (o3->op_type == OP_RV2SV || + o3->op_type == OP_PADSV || + o3->op_type == OP_HELEM || + o3->op_type == OP_AELEM) + goto wrapref; + if (!contextclass) { + /* \$ accepts any scalar lvalue */ + if (Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; + bad_type_gv(arg, namegv, o3, "scalar"); + } + break; + case '@': + if (o3->op_type == OP_RV2AV || + o3->op_type == OP_PADAV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "array"); + break; + case '%': + if (o3->op_type == OP_RV2HV || + o3->op_type == OP_PADHV) + { + o3->op_flags &=~ OPf_PARENS; + goto wrapref; + } + if (!contextclass) + bad_type_gv(arg, namegv, o3, "hash"); + break; + wrapref: aop = S_op_sibling_newUNOP(aTHX_ parent, prev, OP_REFGEN, 0); - if (contextclass && e) { - proto = e + 1; - contextclass = 0; - } - break; - default: goto oops; - } - if (contextclass) - goto again; - break; - case ' ': - proto++; - continue; - default: - oops: { - Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, - SVfARG(cv_name((CV *)namegv, NULL, 0)), - SVfARG(protosv)); + if (contextclass && e) { + proto = e + 1; + contextclass = 0; + } + break; + default: goto oops; + } + if (contextclass) + goto again; + break; + case ' ': + proto++; + continue; + default: + oops: { + Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, + SVfARG(cv_name((CV *)namegv, NULL, 0)), + SVfARG(protosv)); } - } + } - op_lvalue(aop, OP_ENTERSUB); - prev = aop; - aop = OpSIBLING(aop); + op_lvalue(aop, OP_ENTERSUB); + prev = aop; + aop = OpSIBLING(aop); } if (aop == cvop && *proto == '_') { - /* generate an access to $_ */ + /* generate an access to $_ */ op_sibling_splice(parent, prev, 0, newDEFSVOP()); } if (!optional && proto_end > proto && - (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) + (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) { - SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); } return entersubop; } @@ -14731,13 +15005,13 @@ by the name defined by the C parameter. OP * Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, - GV *namegv, SV *protosv) + GV *namegv, SV *protosv) { PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST; if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) - return ck_entersub_args_proto(entersubop, namegv, protosv); + return ck_entersub_args_proto(entersubop, namegv, protosv); else - return ck_entersub_args_list(entersubop); + return ck_entersub_args_list(entersubop); } OP * @@ -14750,53 +15024,53 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE; if (!opnum) { - OP *cvop; - if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; - aop = OpSIBLING(aop); - for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; - if (aop != cvop) { - SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); - } - - op_free(entersubop); - switch(cvflags >> 16) { - case 'F': return newSVOP(OP_CONST, 0, - newSVpv(CopFILE(PL_curcop),0)); - case 'L': return newSVOP( - OP_CONST, 0, + OP *cvop; + if (!OpHAS_SIBLING(aop)) + aop = cUNOPx(aop)->op_first; + aop = OpSIBLING(aop); + for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ; + if (aop != cvop) { + SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } + + op_free(entersubop); + switch(cvflags >> 16) { + case 'F': return newSVOP(OP_CONST, 0, + newSVpv(CopFILE(PL_curcop),0)); + case 'L': return newSVOP( + OP_CONST, 0, Perl_newSVpvf(aTHX_ - "%" IVdf, (IV)CopLINE(PL_curcop) - ) - ); - case 'P': return newSVOP(OP_CONST, 0, - (PL_curstash - ? newSVhek(HvNAME_HEK(PL_curstash)) - : &PL_sv_undef - ) - ); - } - NOT_REACHED; /* NOTREACHED */ + "%" IVdf, (IV)CopLINE(PL_curcop) + ) + ); + case 'P': return newSVOP(OP_CONST, 0, + (PL_curstash + ? newSVhek(HvNAME_HEK(PL_curstash)) + : &PL_sv_undef + ) + ); + } + NOT_REACHED; /* NOTREACHED */ } else { - OP *prev, *cvop, *first, *parent; - U32 flags = 0; + OP *prev, *cvop, *first, *parent; + U32 flags = 0; parent = entersubop; if (!OpHAS_SIBLING(aop)) { parent = aop; - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; } - first = prev = aop; - aop = OpSIBLING(aop); + first = prev = aop; + aop = OpSIBLING(aop); /* find last sibling */ - for (cvop = aop; - OpHAS_SIBLING(cvop); - prev = cvop, cvop = OpSIBLING(cvop)) - ; + for (cvop = aop; + OpHAS_SIBLING(cvop); + prev = cvop, cvop = OpSIBLING(cvop)) + ; if (!(cvop->op_private & OPpENTERSUB_NOPAREN) /* Usually, OPf_SPECIAL on an op with no args means that it had * parens, but these have their own meaning for that flag: */ @@ -14805,50 +15079,50 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) flags |= OPf_SPECIAL; /* excise cvop from end of sibling chain */ op_sibling_splice(parent, prev, 1, NULL); - op_free(cvop); - if (aop == cvop) aop = NULL; + op_free(cvop); + if (aop == cvop) aop = NULL; /* detach remaining siblings from the first sibling, then * dispose of original optree */ if (aop) op_sibling_splice(parent, first, -1, NULL); - op_free(entersubop); + op_free(entersubop); - if (cvflags == (OP_ENTEREVAL | (1<<16))) - flags |= OPpEVAL_BYTES <<8; + if (cvflags == (OP_ENTEREVAL | (1<<16))) + flags |= OPpEVAL_BYTES <<8; - switch (PL_opargs[opnum] & OA_CLASS_MASK) { - case OA_UNOP: - case OA_BASEOP_OR_UNOP: - case OA_FILESTATOP: - if (!aop) + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_UNOP: + case OA_BASEOP_OR_UNOP: + case OA_FILESTATOP: + if (!aop) return newOP(opnum,flags); /* zero args */ if (aop == prev) return newUNOP(opnum,flags,aop); /* one arg */ /* too many args */ /* FALLTHROUGH */ - case OA_BASEOP: - if (aop) { - SV *namesv; + case OA_BASEOP: + if (aop) { + SV *namesv; OP *nextop; - namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, - SVfARG(namesv)), SvUTF8(namesv)); + namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, + SVfARG(namesv)), SvUTF8(namesv)); while (aop) { nextop = OpSIBLING(aop); op_free(aop); aop = nextop; } - } - return opnum == OP_RUNCV - ? newPVOP(OP_RUNCV,0,NULL) - : newOP(opnum,0); - default: - return op_convert_list(opnum,0,aop); - } + } + return opnum == OP_RUNCV + ? newPVOP(OP_RUNCV,0,NULL) + : newOP(opnum,0); + default: + return op_convert_list(opnum,0,aop); + } } NOT_REACHED; /* NOTREACHED */ return entersubop; @@ -14914,20 +15188,20 @@ it is only safe to call it with a genuine GV as its C argument. void Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags, - Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p) + Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p) { MAGIC *callmg; PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS; PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { - *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); - *ckobj_p = callmg->mg_obj; - *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV; + *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); + *ckobj_p = callmg->mg_obj; + *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV; } else { - *ckfun_p = Perl_ck_entersub_args_proto_or_list; - *ckobj_p = (SV*)cv; - *ckflags_p = gflags & MGf_REQUIRE_GV; + *ckfun_p = Perl_ck_entersub_args_proto_or_list; + *ckobj_p = (SV*)cv; + *ckflags_p = gflags & MGf_REQUIRE_GV; } } @@ -14938,7 +15212,7 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; PERL_UNUSED_CONTEXT; cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p, - &ckflags); + &ckflags); } /* @@ -14997,29 +15271,29 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, - SV *ckobj, U32 ckflags) + SV *ckobj, U32 ckflags) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { - if (SvMAGICAL((SV*)cv)) - mg_free_type((SV*)cv, PERL_MAGIC_checkcall); + if (SvMAGICAL((SV*)cv)) + mg_free_type((SV*)cv, PERL_MAGIC_checkcall); } else { - MAGIC *callmg; - sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); - callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); - assert(callmg); - if (callmg->mg_flags & MGf_REFCOUNTED) { - SvREFCNT_dec(callmg->mg_obj); - callmg->mg_flags &= ~MGf_REFCOUNTED; - } - callmg->mg_ptr = FPTR2DPTR(char *, ckfun); - callmg->mg_obj = ckobj; - if (ckobj != (SV*)cv) { - SvREFCNT_inc_simple_void_NN(ckobj); - callmg->mg_flags |= MGf_REFCOUNTED; - } - callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) - | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY; + MAGIC *callmg; + sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); + callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); + assert(callmg); + if (callmg->mg_flags & MGf_REFCOUNTED) { + SvREFCNT_dec(callmg->mg_obj); + callmg->mg_flags &= ~MGf_REFCOUNTED; + } + callmg->mg_ptr = FPTR2DPTR(char *, ckfun); + callmg->mg_obj = ckobj; + if (ckobj != (SV*)cv) { + SvREFCNT_inc_simple_void_NN(ckobj); + callmg->mg_flags |= MGf_REFCOUNTED; + } + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -15042,7 +15316,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = cUNOPx(o)->op_first; if (!OpHAS_SIBLING(aop)) - aop = cUNOPx(aop)->op_first; + aop = cUNOPx(aop)->op_first; aop = OpSIBLING(aop); for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); @@ -15051,77 +15325,77 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private &= ~1; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) - o->op_private |= OPpENTERSUB_DB; + o->op_private |= OPpENTERSUB_DB; switch (cvop->op_type) { - case OP_RV2CV: - o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); - op_null(cvop); - break; - case OP_METHOD: - case OP_METHOD_NAMED: - case OP_METHOD_SUPER: - case OP_METHOD_REDIR: - case OP_METHOD_REDIR_SUPER: - o->op_flags |= OPf_REF; - if (aop->op_type == OP_CONST) { - aop->op_private &= ~OPpCONST_STRICT; - const_class = &cSVOPx(aop)->op_sv; - } - else if (aop->op_type == OP_LIST) { - OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); - if (sib && sib->op_type == OP_CONST) { - sib->op_private &= ~OPpCONST_STRICT; - const_class = &cSVOPx(sib)->op_sv; - } - } - /* make class name a shared cow string to speedup method calls */ - /* constant string might be replaced with object, f.e. bigint */ - if (const_class && SvPOK(*const_class)) { - STRLEN len; - const char* str = SvPV(*const_class, len); - if (len) { - SV* const shared = newSVpvn_share( - str, SvUTF8(*const_class) + case OP_RV2CV: + o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); + op_null(cvop); + break; + case OP_METHOD: + case OP_METHOD_NAMED: + case OP_METHOD_SUPER: + case OP_METHOD_REDIR: + case OP_METHOD_REDIR_SUPER: + o->op_flags |= OPf_REF; + if (aop->op_type == OP_CONST) { + aop->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(aop)->op_sv; + } + else if (aop->op_type == OP_LIST) { + OP * const sib = OpSIBLING(((UNOP*)aop)->op_first); + if (sib && sib->op_type == OP_CONST) { + sib->op_private &= ~OPpCONST_STRICT; + const_class = &cSVOPx(sib)->op_sv; + } + } + /* make class name a shared cow string to speedup method calls */ + /* constant string might be replaced with object, f.e. bigint */ + if (const_class && SvPOK(*const_class)) { + STRLEN len; + const char* str = SvPV(*const_class, len); + if (len) { + SV* const shared = newSVpvn_share( + str, SvUTF8(*const_class) ? -(SSize_t)len : (SSize_t)len, 0 - ); + ); if (SvREADONLY(*const_class)) SvREADONLY_on(shared); - SvREFCNT_dec(*const_class); - *const_class = shared; - } - } - break; + SvREFCNT_dec(*const_class); + *const_class = shared; + } + } + break; } if (!cv) { - S_entersub_alloc_targ(aTHX_ o); - return ck_entersub_args_list(o); + S_entersub_alloc_targ(aTHX_ o); + return ck_entersub_args_list(o); } else { - Perl_call_checker ckfun; - SV *ckobj; - U32 ckflags; - cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags); - if (CvISXSUB(cv) || !CvROOT(cv)) - S_entersub_alloc_targ(aTHX_ o); - if (!namegv) { - /* The original call checker API guarantees that a GV will be - be provided with the right name. So, if the old API was - used (or the REQUIRE_GV flag was passed), we have to reify - the CV’s GV, unless this is an anonymous sub. This is not - ideal for lexical subs, as its stringification will include - the package. But it is the best we can do. */ - if (ckflags & CALL_CHECKER_REQUIRE_GV) { - if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) - namegv = CvGV(cv); - } - else namegv = MUTABLE_GV(cv); - /* After a syntax error in a lexical sub, the cv that - rv2cv_op_cv returns may be a nameless stub. */ - if (!namegv) return ck_entersub_args_list(o); - - } - return ckfun(aTHX_ o, namegv, ckobj); + Perl_call_checker ckfun; + SV *ckobj; + U32 ckflags; + cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags); + if (CvISXSUB(cv) || !CvROOT(cv)) + S_entersub_alloc_targ(aTHX_ o); + if (!namegv) { + /* The original call checker API guarantees that a GV will + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (ckflags & CALL_CHECKER_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); + /* After a syntax error in a lexical sub, the cv that + rv2cv_op_cv returns may be a nameless stub. */ + if (!namegv) return ck_entersub_args_list(o); + + } + return ckfun(aTHX_ o, namegv, ckobj); } } @@ -15138,10 +15412,10 @@ Perl_ck_svconst(pTHX_ OP *o) that constant, mark the constant as COWable here, if it is not already read-only. */ if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { - SvIsCOW_on(sv); - CowREFCNT(sv) = 0; + SvIsCOW_on(sv); + CowREFCNT(sv) = 0; # ifdef PERL_DEBUG_READONLY_COW - sv_buf_to_ro(sv); + sv_buf_to_ro(sv); # endif } #endif @@ -15155,17 +15429,20 @@ Perl_ck_trunc(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_TRUNC; if (o->op_flags & OPf_KIDS) { - SVOP *kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_NULL) - kid = (SVOP*)OpSIBLING(kid); - if (kid && kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE) && - !kid->op_folded) - { - o->op_flags |= OPf_SPECIAL; - kid->op_private &= ~OPpCONST_STRICT; - } + SVOP *kid = (SVOP*)cUNOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = (SVOP*)OpSIBLING(kid); + if (kid && kid->op_type == OP_CONST && + (kid->op_private & OPpCONST_BARE) && + !kid->op_folded) + { + o->op_flags |= OPf_SPECIAL; + kid->op_private &= ~OPpCONST_STRICT; + if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) { + no_bareword_filehandle(SvPVX(cSVOPx_sv(kid))); + } + } } return ck_fun(o); } @@ -15177,15 +15454,15 @@ Perl_ck_substr(pTHX_ OP *o) o = ck_fun(o); if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) { - OP *kid = cLISTOPo->op_first; + OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_NULL) - kid = OpSIBLING(kid); - if (kid) - /* Historically, substr(delete $foo{bar},...) has been allowed - with 4-arg substr. Keep it working by applying entersub - lvalue context. */ - op_lvalue(kid, OP_ENTERSUB); + if (kid->op_type == OP_NULL) + kid = OpSIBLING(kid); + if (kid) + /* Historically, substr(delete $foo{bar},...) has been allowed + with 4-arg substr. Keep it working by applying entersub + lvalue context. */ + op_lvalue(kid, OP_ENTERSUB); } return o; @@ -15201,45 +15478,110 @@ Perl_ck_tell(pTHX_ OP *o) if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid); if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; } - return o; + return o; +} + +PERL_STATIC_INLINE OP * +S_last_non_null_kid(OP *o) { + OP *last = NULL; + if (cUNOPo->op_flags & OPf_KIDS) { + OP *k = cLISTOPo->op_first; + while (k) { + if (k->op_type != OP_NULL) { + last = k; + } + k = OpSIBLING(k); + } + } + + return last; } OP * Perl_ck_each(pTHX_ OP *o) { - dVAR; OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL; const unsigned orig_type = o->op_type; PERL_ARGS_ASSERT_CK_EACH; if (kid) { - switch (kid->op_type) { - case OP_PADHV: - case OP_RV2HV: - break; - case OP_PADAV: - case OP_RV2AV: + switch (kid->op_type) { + case OP_PADHV: + break; + + case OP_RV2HV: + /* Catch out an anonhash here, since the behaviour might be + * confusing. + * + * The typical tree is: + * + * rv2hv + * scope + * null + * anonhash + * + * If the contents of the block is more complex you might get: + * + * rv2hv + * leave + * enter + * ... + * anonhash + * + * Similarly for the anonlist version below. + */ + if (orig_type == OP_EACH && + ckWARN(WARN_SYNTAX) && + (cUNOPx(kid)->op_flags & OPf_KIDS) && + ( cUNOPx(kid)->op_first->op_type == OP_SCOPE || + cUNOPx(kid)->op_first->op_type == OP_LEAVE) && + (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) { + /* look for last non-null kid, since we might have: + each %{ some code ; +{ anon hash } } + */ + OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first); + if (k && k->op_type == OP_ANONHASH) { + /* diag_listed_as: each on anonymous %s will always start from the beginning */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning"); + } + } + break; + case OP_RV2AV: + if (orig_type == OP_EACH && + ckWARN(WARN_SYNTAX) && + (cUNOPx(kid)->op_flags & OPf_KIDS) && + (cUNOPx(kid)->op_first->op_type == OP_SCOPE || + cUNOPx(kid)->op_first->op_type == OP_LEAVE) && + (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) { + OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first); + if (k && k->op_type == OP_ANONLIST) { + /* diag_listed_as: each on anonymous %s will always start from the beginning */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning"); + } + } + /* FALLTHROUGH */ + case OP_PADAV: OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES); - break; - case OP_CONST: - if (kid->op_private == OPpCONST_BARE - || !SvROK(cSVOPx_sv(kid)) - || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV - && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) - ) - goto bad; + break; + case OP_CONST: + if (kid->op_private == OPpCONST_BARE + || !SvROK(cSVOPx_sv(kid)) + || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV + && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) + ) + goto bad; /* FALLTHROUGH */ - default: + default: qerror(Perl_mess(aTHX_ "Experimental %s on scalar is now forbidden", PL_op_desc[orig_type])); bad: bad_type_pv(1, "hash or array", o, kid); return o; - } + } } return ck_fun(o); } @@ -15263,7 +15605,7 @@ Perl_ck_length(pTHX_ OP *o) case OP_PADAV: case OP_RV2HV: case OP_RV2AV: - name = S_op_varname(aTHX_ kid); + name = S_op_varname(aTHX_ kid); break; default: return o; @@ -15703,11 +16045,15 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p) goto do_next; case OP_UNDEF: - /* undef counts as a scalar on the RHS: - * (undef, $x) = ...; # only 1 scalar on LHS: always safe + /* undef on LHS following a var is significant, e.g. + * my $x = 1; + * @a = (($x, undef) = (2 => $x)); + * # @a shoul be (2,1) not (2,2) + * + * undef on RHS counts as a scalar: * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe */ - if (rhs) + if ((!rhs && *scalars_p) || rhs) (*scalars_p)++; flags = AAS_SAFE_SCALAR; break; @@ -15744,7 +16090,7 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p) } /* if its an unrecognised, non-dangerous op, assume that it - * it the cause of at least one safe scalar */ + * is the cause of at least one safe scalar */ (*scalars_p)++; flags = AAS_SAFE_SCALAR; break; @@ -15813,19 +16159,19 @@ S_inplace_aassign(pTHX_ OP *o) { modop = OpSIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) - return; + return; /* no other operation except sort/reverse */ if (OpHAS_SIBLING(modop)) - return; + return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { - /* skip sort subroutine/block */ - assert(oright->op_type == OP_NULL); - oright = OpSIBLING(oright); + /* skip sort subroutine/block */ + assert(oright->op_type == OP_NULL); + oright = OpSIBLING(oright); } assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL); @@ -15835,31 +16181,31 @@ S_inplace_aassign(pTHX_ OP *o) { /* Check the lhs is an array */ if (!oleft || - (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || OpHAS_SIBLING(oleft) - || (oleft->op_private & OPpLVAL_INTRO) + (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) + || OpHAS_SIBLING(oleft) + || (oleft->op_private & OPpLVAL_INTRO) ) - return; + return; /* Only one thing on the rhs */ if (OpHAS_SIBLING(oright)) - return; + return; /* check the array is the same on both sides */ if (oleft->op_type == OP_RV2AV) { - if (oright->op_type != OP_RV2AV - || !cUNOPx(oright)->op_first - || cUNOPx(oright)->op_first->op_type != OP_GV - || cUNOPx(oleft )->op_first->op_type != OP_GV - || cGVOPx_gv(cUNOPx(oleft)->op_first) != - cGVOPx_gv(cUNOPx(oright)->op_first) - ) - return; + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cUNOPx(oleft )->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return; } else if (oright->op_type != OP_PADAV - || oright->op_targ != oleft->op_targ + || oright->op_targ != oleft->op_targ ) - return; + return; /* This actually is an inplace assignment */ @@ -15872,7 +16218,7 @@ S_inplace_aassign(pTHX_ OP *o) { op_null(o); op_null(oleft_pushmark); if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first) - op_null(cUNOPx(oleft)->op_first); + op_null(cUNOPx(oleft)->op_first); op_null(oleft); } @@ -15898,7 +16244,6 @@ S_inplace_aassign(pTHX_ OP *o) { STATIC void S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) { - dVAR; int pass; UNOP_AUX_item *arg_buf = NULL; bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */ @@ -16205,7 +16550,7 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) if ( o->op_type != OP_AELEM || (o->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) ) maybe_aelemfast = FALSE; @@ -16676,8 +17021,8 @@ S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag) OP **defer = defer_queue[defer_base]; \ CALL_RPEEP(*defer); \ S_prune_chain_head(defer); \ - defer_base = (defer_base + 1) % MAX_DEFERRED; \ - defer_ix--; \ + defer_base = (defer_base + 1) % MAX_DEFERRED; \ + defer_ix--; \ } \ defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ } STMT_END @@ -16693,7 +17038,6 @@ S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag) void Perl_rpeep(pTHX_ OP *o) { - dVAR; OP* oldop = NULL; OP* oldoldop = NULL; OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ @@ -16701,7 +17045,7 @@ Perl_rpeep(pTHX_ OP *o) int defer_ix = -1; if (!o || o->op_opt) - return; + return; assert(o->op_type != OP_FREED); @@ -16709,17 +17053,17 @@ Perl_rpeep(pTHX_ OP *o) SAVEOP(); SAVEVPTR(PL_curcop); for (;; o = o->op_next) { - if (o && o->op_opt) - o = NULL; - if (!o) { - while (defer_ix >= 0) { + if (o && o->op_opt) + o = NULL; + if (!o) { + while (defer_ix >= 0) { OP **defer = defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; CALL_RPEEP(*defer); S_prune_chain_head(defer); } - break; - } + break; + } redo: @@ -16727,10 +17071,10 @@ Perl_rpeep(pTHX_ OP *o) assert(!oldoldop || oldoldop->op_next == oldop); assert(!oldop || oldop->op_next == o); - /* By default, this op has now been optimised. A couple of cases below - clear this again. */ - o->op_opt = 1; - PL_op = o; + /* By default, this op has now been optimised. A couple of cases below + clear this again. */ + o->op_opt = 1; + PL_op = o; /* look for a series of 1 or more aggregate derefs, e.g. * $a[1]{foo}[$i]{$k} @@ -16912,90 +17256,90 @@ Perl_rpeep(pTHX_ OP *o) } - switch (o->op_type) { - case OP_DBSTATE: - PL_curcop = ((COP*)o); /* for warnings */ - break; - case OP_NEXTSTATE: - PL_curcop = ((COP*)o); /* for warnings */ - - /* Optimise a "return ..." at the end of a sub to just be "...". - * This saves 2 ops. Before: - * 1 <;> nextstate(main 1 -e:1) v ->2 - * 4 <@> return K ->5 - * 2 <0> pushmark s ->3 - * - <1> ex-rv2sv sK/1 ->4 - * 3 <#> gvsv[*cat] s ->4 - * - * After: - * - <@> return K ->- - * - <0> pushmark s ->2 - * - <1> ex-rv2sv sK/1 ->- - * 2 <$> gvsv(*cat) s ->3 - */ - { - OP *next = o->op_next; - OP *sibling = OpSIBLING(o); - if ( OP_TYPE_IS(next, OP_PUSHMARK) - && OP_TYPE_IS(sibling, OP_RETURN) - && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) - && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) - ||OP_TYPE_IS(sibling->op_next->op_next, - OP_LEAVESUBLV)) - && cUNOPx(sibling)->op_first == next - && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next - && next->op_next - ) { - /* Look through the PUSHMARK's siblings for one that - * points to the RETURN */ - OP *top = OpSIBLING(next); - while (top && top->op_next) { - if (top->op_next == sibling) { - top->op_next = sibling->op_next; - o->op_next = next->op_next; - break; - } - top = OpSIBLING(top); - } - } - } - - /* Optimise 'my $x; my $y;' into 'my ($x, $y);' + switch (o->op_type) { + case OP_DBSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + break; + case OP_NEXTSTATE: + PL_curcop = ((COP*)o); /* for warnings */ + + /* Optimise a "return ..." at the end of a sub to just be "...". + * This saves 2 ops. Before: + * 1 <;> nextstate(main 1 -e:1) v ->2 + * 4 <@> return K ->5 + * 2 <0> pushmark s ->3 + * - <1> ex-rv2sv sK/1 ->4 + * 3 <#> gvsv[*cat] s ->4 + * + * After: + * - <@> return K ->- + * - <0> pushmark s ->2 + * - <1> ex-rv2sv sK/1 ->- + * 2 <$> gvsv(*cat) s ->3 + */ + { + OP *next = o->op_next; + OP *sibling = OpSIBLING(o); + if ( OP_TYPE_IS(next, OP_PUSHMARK) + && OP_TYPE_IS(sibling, OP_RETURN) + && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) + && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) + ||OP_TYPE_IS(sibling->op_next->op_next, + OP_LEAVESUBLV)) + && cUNOPx(sibling)->op_first == next + && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = OpSIBLING(next); + while (top && top->op_next) { + if (top->op_next == sibling) { + top->op_next = sibling->op_next; + o->op_next = next->op_next; + break; + } + top = OpSIBLING(top); + } + } + } + + /* Optimise 'my $x; my $y;' into 'my ($x, $y);' + * + * This latter form is then suitable for conversion into padrange + * later on. Convert: + * + * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 + * + * into: * - * This latter form is then suitable for conversion into padrange - * later on. Convert: - * - * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 - * - * into: - * - * nextstate1 -> listop -> nextstate3 - * / \ - * pushmark -> padop1 -> padop2 - */ - if (o->op_next && ( - o->op_next->op_type == OP_PADSV - || o->op_next->op_type == OP_PADAV - || o->op_next->op_type == OP_PADHV - ) - && !(o->op_next->op_private & ~OPpLVAL_INTRO) - && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE - && o->op_next->op_next->op_next && ( - o->op_next->op_next->op_next->op_type == OP_PADSV - || o->op_next->op_next->op_next->op_type == OP_PADAV - || o->op_next->op_next->op_next->op_type == OP_PADHV - ) - && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) - && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE - && (!CopLABEL((COP*)o)) /* Don't mess with labels */ - && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ - ) { - OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; - - pad1 = o->op_next; - ns2 = pad1->op_next; - pad2 = ns2->op_next; - ns3 = pad2->op_next; + * nextstate1 -> listop -> nextstate3 + * / \ + * pushmark -> padop1 -> padop2 + */ + if (o->op_next && ( + o->op_next->op_type == OP_PADSV + || o->op_next->op_type == OP_PADAV + || o->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE + && o->op_next->op_next->op_next && ( + o->op_next->op_next->op_next->op_type == OP_PADSV + || o->op_next->op_next->op_next->op_type == OP_PADAV + || o->op_next->op_next->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE + && (!CopLABEL((COP*)o)) /* Don't mess with labels */ + && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ + ) { + OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; + + pad1 = o->op_next; + ns2 = pad1->op_next; + pad2 = ns2->op_next; + ns3 = pad2->op_next; /* we assume here that the op_next chain is the same as * the op_sibling chain */ @@ -17013,35 +17357,35 @@ Perl_rpeep(pTHX_ OP *o) /* create new listop, with children consisting of: * a new pushmark, pad1, pad2. */ - newop = newLISTOP(OP_LIST, 0, pad1, pad2); - newop->op_flags |= OPf_PARENS; - newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + newop = newLISTOP(OP_LIST, 0, pad1, pad2); + newop->op_flags |= OPf_PARENS; + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; /* insert newop between o and ns3 */ op_sibling_splice(NULL, o, 0, newop); /*fixup op_next chain */ newpm = cUNOPx(newop)->op_first; /* pushmark */ - o ->op_next = newpm; - newpm->op_next = pad1; - pad1 ->op_next = pad2; - pad2 ->op_next = newop; /* listop */ - newop->op_next = ns3; - - /* Ensure pushmark has this flag if padops do */ - if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { - newpm->op_flags |= OPf_MOD; - } - - break; - } - - /* Two NEXTSTATEs in a row serve no purpose. Except if they happen - to carry two labels. For now, take the easier option, and skip - this optimisation if the first NEXTSTATE has a label. */ - if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { - OP *nextop = o->op_next; - while (nextop) { + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + /* Ensure pushmark has this flag if padops do */ + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { + newpm->op_flags |= OPf_MOD; + } + + break; + } + + /* Two NEXTSTATEs in a row serve no purpose. Except if they happen + to carry two labels. For now, take the easier option, and skip + this optimisation if the first NEXTSTATE has a label. */ + if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) { + OP *nextop = o->op_next; + while (nextop) { switch (nextop->op_type) { case OP_NULL: case OP_SCALAR: @@ -17053,61 +17397,61 @@ Perl_rpeep(pTHX_ OP *o) break; } - if (nextop && (nextop->op_type == OP_NEXTSTATE)) { - op_null(o); - if (oldop) - oldop->op_next = nextop; + if (nextop && (nextop->op_type == OP_NEXTSTATE)) { + op_null(o); + if (oldop) + oldop->op_next = nextop; o = nextop; - /* Skip (old)oldop assignment since the current oldop's - op_next already points to the next op. */ - goto redo; - } - } - break; - - case OP_CONCAT: - if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { - if (o->op_next->op_private & OPpTARGET_MY) { - if (o->op_flags & OPf_STACKED) /* chained concats */ - break; /* ignore_optimization */ - else { - /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ - o->op_targ = o->op_next->op_targ; - o->op_next->op_targ = 0; - o->op_private |= OPpTARGET_MY; - } - } - op_null(o->op_next); - } - break; - case OP_STUB: - if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - break; /* Scalar stub must produce undef. List stub is noop */ - } - goto nothin; - case OP_NULL: - if (o->op_targ == OP_NEXTSTATE - || o->op_targ == OP_DBSTATE) - { - PL_curcop = ((COP*)o); - } - /* XXX: We avoid setting op_seq here to prevent later calls - to rpeep() from mistakenly concluding that optimisation - has already occurred. This doesn't fix the real problem, - though (See 20010220.007 (#5874)). AMS 20010719 */ - /* op_seq functionality is now replaced by op_opt */ - o->op_opt = 0; - /* FALLTHROUGH */ - case OP_SCALAR: - case OP_LINESEQ: - case OP_SCOPE: - nothin: - if (oldop) { - oldop->op_next = o->op_next; - o->op_opt = 0; - continue; - } - break; + /* Skip (old)oldop assignment since the current oldop's + op_next already points to the next op. */ + goto redo; + } + } + break; + + case OP_CONCAT: + if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { + if (o->op_next->op_private & OPpTARGET_MY) { + if (o->op_flags & OPf_STACKED) /* chained concats */ + break; /* ignore_optimization */ + else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ + o->op_targ = o->op_next->op_targ; + o->op_next->op_targ = 0; + o->op_private |= OPpTARGET_MY; + } + } + op_null(o->op_next); + } + break; + case OP_STUB: + if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { + break; /* Scalar stub must produce undef. List stub is noop */ + } + goto nothin; + case OP_NULL: + if (o->op_targ == OP_NEXTSTATE + || o->op_targ == OP_DBSTATE) + { + PL_curcop = ((COP*)o); + } + /* XXX: We avoid setting op_seq here to prevent later calls + to rpeep() from mistakenly concluding that optimisation + has already occurred. This doesn't fix the real problem, + though (See 20010220.007 (#5874)). AMS 20010719 */ + /* op_seq functionality is now replaced by op_opt */ + o->op_opt = 0; + /* FALLTHROUGH */ + case OP_SCALAR: + case OP_LINESEQ: + case OP_SCOPE: + nothin: + if (oldop) { + oldop->op_next = o->op_next; + o->op_opt = 0; + continue; + } + break; case OP_PUSHMARK: @@ -17402,13 +17746,13 @@ Perl_rpeep(pTHX_ OP *o) break; } - case OP_RV2AV: + case OP_RV2AV: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); break; - case OP_RV2HV: - case OP_PADHV: + case OP_RV2HV: + case OP_PADHV: /*'keys %h' in void or scalar context: skip the OP_KEYS * and perform the functionality directly in the RV2HV/PADHV * op @@ -17444,13 +17788,13 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_type != OP_PADHV) break; /* FALLTHROUGH */ - case OP_PADAV: + case OP_PADAV: if ( o->op_type == OP_PADAV && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR ) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); /* FALLTHROUGH */ - case OP_PADSV: + case OP_PADSV: /* Skip over state($x) in void context. */ if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) @@ -17461,174 +17805,181 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_type != OP_PADAV) break; /* FALLTHROUGH */ - case OP_GV: - if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { - OP* const pop = (o->op_type == OP_PADAV) ? - o->op_next : o->op_next->op_next; - IV i; - if (pop && pop->op_type == OP_CONST && - ((PL_op = pop->op_next)) && - pop->op_next->op_type == OP_AELEM && - !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) - { - GV *gv; - if (cSVOPx(pop)->op_private & OPpCONST_STRICT) - no_bareword_allowed(pop); - if (o->op_type == OP_GV) - op_null(o->op_next); - op_null(pop->op_next); - op_null(pop); - o->op_flags |= pop->op_next->op_flags & OPf_MOD; - o->op_next = pop->op_next->op_next; - o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; - o->op_private = (U8)i; - if (o->op_type == OP_GV) { - gv = cGVOPo_gv; - GvAVn(gv); - o->op_type = OP_AELEMFAST; - } - else - o->op_type = OP_AELEMFAST_LEX; - } - if (o->op_type != OP_GV) - break; - } - - /* Remove $foo from the op_next chain in void context. */ - if (oldop - && ( o->op_next->op_type == OP_RV2SV - || o->op_next->op_type == OP_RV2AV - || o->op_next->op_type == OP_RV2HV ) - && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID - && !(o->op_next->op_private & OPpLVAL_INTRO)) - { - oldop->op_next = o->op_next->op_next; - /* Reprocess the previous op if it is a nextstate, to - allow double-nextstate optimisation. */ - redo_nextstate: - if (oldop->op_type == OP_NEXTSTATE) { - oldop->op_opt = 0; - o = oldop; - oldop = oldoldop; - oldoldop = NULL; - goto redo; - } - o = oldop->op_next; + case OP_GV: + if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { + OP* const pop = (o->op_type == OP_PADAV) ? + o->op_next : o->op_next->op_next; + IV i; + if (pop && pop->op_type == OP_CONST && + ((PL_op = pop->op_next)) && + pop->op_next->op_type == OP_AELEM && + !(pop->op_next->op_private & + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && + (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) + { + GV *gv; + if (cSVOPx(pop)->op_private & OPpCONST_STRICT) + no_bareword_allowed(pop); + if (o->op_type == OP_GV) + op_null(o->op_next); + op_null(pop->op_next); + op_null(pop); + o->op_flags |= pop->op_next->op_flags & OPf_MOD; + o->op_next = pop->op_next->op_next; + o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; + o->op_private = (U8)i; + if (o->op_type == OP_GV) { + gv = cGVOPo_gv; + GvAVn(gv); + o->op_type = OP_AELEMFAST; + } + else + o->op_type = OP_AELEMFAST_LEX; + } + if (o->op_type != OP_GV) + break; + } + + /* Remove $foo from the op_next chain in void context. */ + if (oldop + && ( o->op_next->op_type == OP_RV2SV + || o->op_next->op_type == OP_RV2AV + || o->op_next->op_type == OP_RV2HV ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + && !(o->op_next->op_private & OPpLVAL_INTRO)) + { + oldop->op_next = o->op_next->op_next; + /* Reprocess the previous op if it is a nextstate, to + allow double-nextstate optimisation. */ + redo_nextstate: + if (oldop->op_type == OP_NEXTSTATE) { + oldop->op_opt = 0; + o = oldop; + oldop = oldoldop; + oldoldop = NULL; + goto redo; + } + o = oldop->op_next; goto redo; - } - else if (o->op_next->op_type == OP_RV2SV) { - if (!(o->op_next->op_private & OPpDEREF)) { - op_null(o->op_next); - o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO - | OPpOUR_INTRO); - o->op_next = o->op_next->op_next; + } + else if (o->op_next->op_type == OP_RV2SV) { + if (!(o->op_next->op_private & OPpDEREF)) { + op_null(o->op_next); + o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO + | OPpOUR_INTRO); + o->op_next = o->op_next->op_next; OpTYPE_set(o, OP_GVSV); - } - } - else if (o->op_next->op_type == OP_READLINE - && o->op_next->op_next->op_type == OP_CONCAT - && (o->op_next->op_next->op_flags & OPf_STACKED)) - { - /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ + } + } + else if (o->op_next->op_type == OP_READLINE + && o->op_next->op_next->op_type == OP_CONCAT + && (o->op_next->op_next->op_flags & OPf_STACKED)) + { + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ OpTYPE_set(o, OP_RCATLINE); - o->op_flags |= OPf_STACKED; - op_null(o->op_next->op_next); - op_null(o->op_next); - } + o->op_flags |= OPf_STACKED; + op_null(o->op_next->op_next); + op_null(o->op_next); + } - break; + break; case OP_NOT: break; case OP_AND: - case OP_OR: - case OP_DOR: - case OP_CMPCHAIN_AND: - while (cLOGOP->op_other->op_type == OP_NULL) - cLOGOP->op_other = cLOGOP->op_other->op_next; - while (o->op_next && ( o->op_type == o->op_next->op_type - || o->op_next->op_type == OP_NULL)) - o->op_next = o->op_next->op_next; - - /* If we're an OR and our next is an AND in void context, we'll - follow its op_other on short circuit, same for reverse. - We can't do this with OP_DOR since if it's true, its return - value is the underlying value which must be evaluated - by the next op. */ - if (o->op_next && - ( - (IS_AND_OP(o) && IS_OR_OP(o->op_next)) - || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) - ) - && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID - ) { - o->op_next = ((LOGOP*)o->op_next)->op_other; - } - DEFER(cLOGOP->op_other); - o->op_opt = 1; - break; - - case OP_GREPWHILE: + case OP_OR: + case OP_DOR: + case OP_CMPCHAIN_AND: + case OP_PUSHDEFER: + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + while (o->op_next && ( o->op_type == o->op_next->op_type + || o->op_next->op_type == OP_NULL)) + o->op_next = o->op_next->op_next; + + /* If we're an OR and our next is an AND in void context, we'll + follow its op_other on short circuit, same for reverse. + We can't do this with OP_DOR since if it's true, its return + value is the underlying value which must be evaluated + by the next op. */ + if (o->op_next && + ( + (IS_AND_OP(o) && IS_OR_OP(o->op_next)) + || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) + ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + ) { + o->op_next = ((LOGOP*)o->op_next)->op_other; + } + DEFER(cLOGOP->op_other); + o->op_opt = 1; + break; + + case OP_GREPWHILE: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); /* FALLTHROUGH */ - case OP_COND_EXPR: - case OP_MAPWHILE: - case OP_ANDASSIGN: - case OP_ORASSIGN: - case OP_DORASSIGN: - case OP_RANGE: - case OP_ONCE: - case OP_ARGDEFELEM: - while (cLOGOP->op_other->op_type == OP_NULL) - cLOGOP->op_other = cLOGOP->op_other->op_next; - DEFER(cLOGOP->op_other); - break; - - case OP_ENTERLOOP: - case OP_ENTERITER: - while (cLOOP->op_redoop->op_type == OP_NULL) - cLOOP->op_redoop = cLOOP->op_redoop->op_next; - while (cLOOP->op_nextop->op_type == OP_NULL) - cLOOP->op_nextop = cLOOP->op_nextop->op_next; - while (cLOOP->op_lastop->op_type == OP_NULL) - cLOOP->op_lastop = cLOOP->op_lastop->op_next; - /* a while(1) loop doesn't have an op_next that escapes the - * loop, so we have to explicitly follow the op_lastop to - * process the rest of the code */ - DEFER(cLOOP->op_lastop); - break; + case OP_COND_EXPR: + case OP_MAPWHILE: + case OP_ANDASSIGN: + case OP_ORASSIGN: + case OP_DORASSIGN: + case OP_RANGE: + case OP_ONCE: + case OP_ARGDEFELEM: + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + DEFER(cLOGOP->op_other); + break; + + case OP_ENTERLOOP: + case OP_ENTERITER: + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; + /* a while(1) loop doesn't have an op_next that escapes the + * loop, so we have to explicitly follow the op_lastop to + * process the rest of the code */ + DEFER(cLOOP->op_lastop); + break; case OP_ENTERTRY: - assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); - DEFER(cLOGOPo->op_other); - break; + assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); + DEFER(cLOGOPo->op_other); + break; + + case OP_ENTERTRYCATCH: + assert(cLOGOPo->op_other->op_type == OP_CATCH); + /* catch body is the ->op_other of the OP_CATCH */ + DEFER(cLOGOPx(cLOGOPo->op_other)->op_other); + break; - case OP_SUBST: + case OP_SUBST: if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); - assert(!(cPMOP->op_pmflags & PMf_ONCE)); - while (cPMOP->op_pmstashstartu.op_pmreplstart && - cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) - cPMOP->op_pmstashstartu.op_pmreplstart - = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; - DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); - break; - - case OP_SORT: { - OP *oright; - - if (o->op_flags & OPf_SPECIAL) { + assert(!(cPMOP->op_pmflags & PMf_ONCE)); + while (cPMOP->op_pmstashstartu.op_pmreplstart && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + DEFER(cPMOP->op_pmstashstartu.op_pmreplstart); + break; + + case OP_SORT: { + OP *oright; + + if (o->op_flags & OPf_SPECIAL) { /* first arg is a code block */ OP * const nullop = OpSIBLING(cLISTOP->op_first); OP * kid = cUNOPx(nullop)->op_first; assert(nullop->op_type == OP_NULL); - assert(kid->op_type == OP_SCOPE - || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); + assert(kid->op_type == OP_SCOPE + || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); /* since OP_SORT doesn't have a handy op_other-style * field that can point directly to the start of the code * block, store it in the otherwise-unused op_next field @@ -17646,167 +17997,167 @@ Perl_rpeep(pTHX_ OP *o) || (PL_parser && PL_parser->error_count)); nullop->op_next = kid->op_next; DEFER(nullop->op_next); - } - - /* check that RHS of sort is a single plain array */ - oright = cUNOPo->op_first; - if (!oright || oright->op_type != OP_PUSHMARK) - break; - - if (o->op_private & OPpSORT_INPLACE) - break; - - /* reverse sort ... can be optimised. */ - if (!OpHAS_SIBLING(cUNOPo)) { - /* Nothing follows us on the list. */ - OP * const reverse = o->op_next; - - if (reverse->op_type == OP_REVERSE && - (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { - OP * const pushmark = cUNOPx(reverse)->op_first; - if (pushmark && (pushmark->op_type == OP_PUSHMARK) - && (OpSIBLING(cUNOPx(pushmark)) == o)) { - /* reverse -> pushmark -> sort */ - o->op_private |= OPpSORT_REVERSE; - op_null(reverse); - pushmark->op_next = oright->op_next; - op_null(oright); - } - } - } - - break; - } - - case OP_REVERSE: { - OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; - OP *gvop = NULL; - LISTOP *enter, *exlist; - - if (o->op_private & OPpSORT_INPLACE) - break; - - enter = (LISTOP *) o->op_next; - if (!enter) - break; - if (enter->op_type == OP_NULL) { - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - } - /* for $a (...) will have OP_GV then OP_RV2GV here. - for (...) just has an OP_GV. */ - if (enter->op_type == OP_GV) { - gvop = (OP *) enter; - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - if (enter->op_type == OP_RV2GV) { - enter = (LISTOP *) enter->op_next; - if (!enter) - break; - } - } - - if (enter->op_type != OP_ENTERITER) - break; - - iter = enter->op_next; - if (!iter || iter->op_type != OP_ITER) - break; - - expushmark = enter->op_first; - if (!expushmark || expushmark->op_type != OP_NULL - || expushmark->op_targ != OP_PUSHMARK) - break; - - exlist = (LISTOP *) OpSIBLING(expushmark); - if (!exlist || exlist->op_type != OP_NULL - || exlist->op_targ != OP_LIST) - break; - - if (exlist->op_last != o) { - /* Mmm. Was expecting to point back to this op. */ - break; - } - theirmark = exlist->op_first; - if (!theirmark || theirmark->op_type != OP_PUSHMARK) - break; - - if (OpSIBLING(theirmark) != o) { - /* There's something between the mark and the reverse, eg - for (1, reverse (...)) - so no go. */ - break; - } - - ourmark = ((LISTOP *)o)->op_first; - if (!ourmark || ourmark->op_type != OP_PUSHMARK) - break; - - ourlast = ((LISTOP *)o)->op_last; - if (!ourlast || ourlast->op_next != o) - break; - - rv2av = OpSIBLING(ourmark); - if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) - && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { - /* We're just reversing a single array. */ - rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; - enter->op_flags |= OPf_STACKED; - } - - /* We don't have control over who points to theirmark, so sacrifice - ours. */ - theirmark->op_next = ourmark->op_next; - theirmark->op_flags = ourmark->op_flags; - ourlast->op_next = gvop ? gvop : (OP *) enter; - op_null(ourmark); - op_null(o); - enter->op_private |= OPpITER_REVERSED; - iter->op_private |= OPpITER_REVERSED; + } + + /* check that RHS of sort is a single plain array */ + oright = cUNOPo->op_first; + if (!oright || oright->op_type != OP_PUSHMARK) + break; + + if (o->op_private & OPpSORT_INPLACE) + break; + + /* reverse sort ... can be optimised. */ + if (!OpHAS_SIBLING(cUNOPo)) { + /* Nothing follows us on the list. */ + OP * const reverse = o->op_next; + + if (reverse->op_type == OP_REVERSE && + (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { + OP * const pushmark = cUNOPx(reverse)->op_first; + if (pushmark && (pushmark->op_type == OP_PUSHMARK) + && (OpSIBLING(cUNOPx(pushmark)) == o)) { + /* reverse -> pushmark -> sort */ + o->op_private |= OPpSORT_REVERSE; + op_null(reverse); + pushmark->op_next = oright->op_next; + op_null(oright); + } + } + } + + break; + } + + case OP_REVERSE: { + OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; + OP *gvop = NULL; + LISTOP *enter, *exlist; + + if (o->op_private & OPpSORT_INPLACE) + break; + + enter = (LISTOP *) o->op_next; + if (!enter) + break; + if (enter->op_type == OP_NULL) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + /* for $a (...) will have OP_GV then OP_RV2GV here. + for (...) just has an OP_GV. */ + if (enter->op_type == OP_GV) { + gvop = (OP *) enter; + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + if (enter->op_type == OP_RV2GV) { + enter = (LISTOP *) enter->op_next; + if (!enter) + break; + } + } + + if (enter->op_type != OP_ENTERITER) + break; + + iter = enter->op_next; + if (!iter || iter->op_type != OP_ITER) + break; + + expushmark = enter->op_first; + if (!expushmark || expushmark->op_type != OP_NULL + || expushmark->op_targ != OP_PUSHMARK) + break; + + exlist = (LISTOP *) OpSIBLING(expushmark); + if (!exlist || exlist->op_type != OP_NULL + || exlist->op_targ != OP_LIST) + break; + + if (exlist->op_last != o) { + /* Mmm. Was expecting to point back to this op. */ + break; + } + theirmark = exlist->op_first; + if (!theirmark || theirmark->op_type != OP_PUSHMARK) + break; + + if (OpSIBLING(theirmark) != o) { + /* There's something between the mark and the reverse, eg + for (1, reverse (...)) + so no go. */ + break; + } + + ourmark = ((LISTOP *)o)->op_first; + if (!ourmark || ourmark->op_type != OP_PUSHMARK) + break; + + ourlast = ((LISTOP *)o)->op_last; + if (!ourlast || ourlast->op_next != o) + break; + + rv2av = OpSIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av) + && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { + /* We're just reversing a single array. */ + rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF; + enter->op_flags |= OPf_STACKED; + } + + /* We don't have control over who points to theirmark, so sacrifice + ours. */ + theirmark->op_next = ourmark->op_next; + theirmark->op_flags = ourmark->op_flags; + ourlast->op_next = gvop ? gvop : (OP *) enter; + op_null(ourmark); + op_null(o); + enter->op_private |= OPpITER_REVERSED; + iter->op_private |= OPpITER_REVERSED; oldoldop = NULL; oldop = ourlast; o = oldop->op_next; goto redo; NOT_REACHED; /* NOTREACHED */ - break; - } - - case OP_QR: - case OP_MATCH: - if (!(cPMOP->op_pmflags & PMf_ONCE)) { - assert (!cPMOP->op_pmstashstartu.op_pmreplstart); - } - break; - - case OP_RUNCV: - if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) - && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) - { - SV *sv; - if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; - else { - sv = newRV((SV *)PL_compcv); - sv_rvweaken(sv); - SvREADONLY_on(sv); - } + break; + } + + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } + break; + + case OP_RUNCV: + if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv) + && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb))) + { + SV *sv; + if (CvEVAL(PL_compcv)) sv = &PL_sv_undef; + else { + sv = newRV((SV *)PL_compcv); + sv_rvweaken(sv); + SvREADONLY_on(sv); + } OpTYPE_set(o, OP_CONST); - o->op_flags |= OPf_SPECIAL; - cSVOPo->op_sv = sv; - } - break; - - case OP_SASSIGN: - if (OP_GIMME(o,0) == G_VOID - || ( o->op_next->op_type == OP_LINESEQ - && ( o->op_next->op_next->op_type == OP_LEAVESUB - || ( o->op_next->op_next->op_type == OP_RETURN - && !CvLVALUE(PL_compcv))))) - { - OP *right = cBINOP->op_first; - if (right) { + o->op_flags |= OPf_SPECIAL; + cSVOPo->op_sv = sv; + } + break; + + case OP_SASSIGN: + if (OP_GIMME(o,0) == G_VOID + || ( o->op_next->op_type == OP_LINESEQ + && ( o->op_next->op_next->op_type == OP_LEAVESUB + || ( o->op_next->op_next->op_type == OP_RETURN + && !CvLVALUE(PL_compcv))))) + { + OP *right = cBINOP->op_first; + if (right) { /* sassign * RIGHT * substr @@ -17824,24 +18175,24 @@ Perl_rpeep(pTHX_ OP *o) * arg2 * ... */ - OP *left = OpSIBLING(right); - if (left->op_type == OP_SUBSTR - && (left->op_private & 7) < 4) { - op_null(o); + OP *left = OpSIBLING(right); + if (left->op_type == OP_SUBSTR + && (left->op_private & 7) < 4) { + op_null(o); /* cut out right */ op_sibling_splice(o, NULL, 1, NULL); /* and insert it as second child of OP_SUBSTR */ op_sibling_splice(left, cBINOPx(left)->op_first, 0, right); - left->op_private |= OPpSUBSTR_REPL_FIRST; - left->op_flags = - (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; - } - } - } - break; - - case OP_AASSIGN: { + left->op_private |= OPpSUBSTR_REPL_FIRST; + left->op_flags = + (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + } + } + } + break; + + case OP_AASSIGN: { int l, r, lr, lscalars, rscalars; /* handle common vars detection, e.g. ($a,$b) = ($b,$a). @@ -17883,7 +18234,7 @@ Perl_rpeep(pTHX_ OP *o) || !r /* .... = (); */ || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */ || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */ - || (lscalars < 2) /* ($x, undef) = ... */ + || (lscalars < 2) /* (undef, $x) = ... */ ) { NOOP; /* always safe */ } @@ -17945,11 +18296,14 @@ Perl_rpeep(pTHX_ OP *o) if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0); - break; + break; } case OP_REF: - /* see if ref() is used in boolean context */ + case OP_BLESSED: + /* if the op is used in boolean context, set the TRUEBOOL flag + * which enables an optimisation at runtime which avoids creating + * a stack temporary for known-true package names */ if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); break; @@ -17969,15 +18323,15 @@ Perl_rpeep(pTHX_ OP *o) S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0); break; - case OP_CUSTOM: { - Perl_cpeep_t cpeep = - XopENTRYCUSTOM(o, xop_peep); - if (cpeep) - cpeep(aTHX_ o, oldop); - break; - } + case OP_CUSTOM: { + Perl_cpeep_t cpeep = + XopENTRYCUSTOM(o, xop_peep); + if (cpeep) + cpeep(aTHX_ o, oldop); + break; + } - } + } /* did we just null the current op? If so, re-process it to handle * eliding "empty" ops from the chain */ if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { @@ -17999,7 +18353,7 @@ Perl_peep(pTHX_ OP *o) } /* -=head1 Custom Operators +=for apidoc_section $custom =for apidoc Perl_custom_op_xop Return the XOP structure for a given custom op. This macro should be @@ -18064,7 +18418,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr))); if (PL_custom_ops) - he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); + he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); /* See if the op isn't registered, but its name *is* registered. * That implies someone is using the pre-5.14 API,where only name and @@ -18073,23 +18427,23 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) * We only check for an existing name, and assume no one will have * just registered a desc */ if (!he && PL_custom_op_names && - (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) + (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0)) ) { - const char *pv; - STRLEN l; - - /* XXX does all this need to be shared mem? */ - Newxz(xop, 1, XOP); - pv = SvPV(HeVAL(he), l); - XopENTRY_set(xop, xop_name, savepvn(pv, l)); - if (PL_custom_op_descs && - (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) - ) { - pv = SvPV(HeVAL(he), l); - XopENTRY_set(xop, xop_desc, savepvn(pv, l)); - } - Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); - he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); + const char *pv; + STRLEN l; + + /* XXX does all this need to be shared mem? */ + Newxz(xop, 1, XOP); + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_name, savepvn(pv, l)); + if (PL_custom_op_descs && + (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0)) + ) { + pv = SvPV(HeVAL(he), l); + XopENTRY_set(xop, xop_desc, savepvn(pv, l)); + } + Perl_custom_op_register(aTHX_ o->op_ppaddr, xop); + he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0); /* add magic to the SV so that the xop struct (pointed to by * SvIV(sv)) is freed. Normally a static xop is registered, but * for this backcompat hack, we've alloced one */ @@ -18098,62 +18452,60 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) } else { - if (!he) - xop = (XOP *)&xop_null; - else - xop = INT2PTR(XOP *, SvIV(HeVAL(he))); + if (!he) + xop = (XOP *)&xop_null; + else + xop = INT2PTR(XOP *, SvIV(HeVAL(he))); } + { - XOPRETANY any; - if(field == XOPe_xop_ptr) { - any.xop_ptr = xop; - } else { - const U32 flags = XopFLAGS(xop); - if(flags & field) { - switch(field) { - case XOPe_xop_name: - any.xop_name = xop->xop_name; - break; - case XOPe_xop_desc: - any.xop_desc = xop->xop_desc; - break; - case XOPe_xop_class: - any.xop_class = xop->xop_class; - break; - case XOPe_xop_peep: - any.xop_peep = xop->xop_peep; - break; - default: - NOT_REACHED; /* NOTREACHED */ - break; - } - } else { - switch(field) { - case XOPe_xop_name: - any.xop_name = XOPd_xop_name; - break; - case XOPe_xop_desc: - any.xop_desc = XOPd_xop_desc; - break; - case XOPe_xop_class: - any.xop_class = XOPd_xop_class; - break; - case XOPe_xop_peep: - any.xop_peep = XOPd_xop_peep; - break; - default: - NOT_REACHED; /* NOTREACHED */ - break; - } - } - } - /* On some platforms (HP-UX, IA64) gcc emits a warning for this function: - * op.c: In function 'Perl_custom_op_get_field': - * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized] - * This is because on those platforms (with -DEBUGGING) NOT_REACHED - * expands to assert(0), which expands to ((0) ? (void)0 : - * __assert(...)), and gcc doesn't know that __assert can never return. */ - return any; + XOPRETANY any; + if(field == XOPe_xop_ptr) { + any.xop_ptr = xop; + } else { + const U32 flags = XopFLAGS(xop); + if(flags & field) { + switch(field) { + case XOPe_xop_name: + any.xop_name = xop->xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = xop->xop_desc; + break; + case XOPe_xop_class: + any.xop_class = xop->xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = xop->xop_peep; + break; + default: + field_panic: + Perl_croak(aTHX_ + "panic: custom_op_get_field(): invalid field %d\n", + (int)field); + break; + } + } else { + switch(field) { + case XOPe_xop_name: + any.xop_name = XOPd_xop_name; + break; + case XOPe_xop_desc: + any.xop_desc = XOPd_xop_desc; + break; + case XOPe_xop_class: + any.xop_class = XOPd_xop_class; + break; + case XOPe_xop_peep: + any.xop_peep = XOPd_xop_peep; + break; + default: + goto field_panic; + break; + } + } + } + return any; } } @@ -18175,10 +18527,10 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) keysv = sv_2mortal(newSViv(PTR2IV(ppaddr))); if (!PL_custom_ops) - PL_custom_ops = newHV(); + PL_custom_ops = newHV(); if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0)) - Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); + Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name); } /* @@ -18221,65 +18573,65 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_redo : case KEY_require: case KEY_return: case KEY_say : case KEY_select: case KEY_sort : case KEY_split : case KEY_system: case KEY_x : case KEY_xor : - if (!opnum) return NULL; nullret = TRUE; goto findopnum; + if (!opnum) return NULL; nullret = TRUE; goto findopnum; case KEY_glob: retsetpvs("_;", OP_GLOB); case KEY_keys: retsetpvs("\\[%@]", OP_KEYS); case KEY_values: retsetpvs("\\[%@]", OP_VALUES); case KEY_each: retsetpvs("\\[%@]", OP_EACH); case KEY_pos: retsetpvs(";\\[$*]", OP_POS); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: - retsetpvs("", 0); + retsetpvs("", 0); case KEY_evalbytes: - name = "entereval"; break; + name = "entereval"; break; case KEY_readpipe: - name = "backtick"; + name = "backtick"; } #undef retsetpvs findopnum: while (i < MAXO) { /* The slow way. */ - if (strEQ(name, PL_op_name[i]) - || strEQ(name, PL_op_desc[i])) - { - if (nullret) { assert(opnum); *opnum = i; return NULL; } - goto found; - } - i++; + if (strEQ(name, PL_op_name[i]) + || strEQ(name, PL_op_desc[i])) + { + if (nullret) { assert(opnum); *opnum = i; return NULL; } + goto found; + } + i++; } return NULL; found: defgv = PL_opargs[i] & OA_DEFGV; oa = PL_opargs[i] >> OASHIFT; while (oa) { - if (oa & OA_OPTIONAL && !seen_question && ( - !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF - )) { - seen_question = 1; - str[n++] = ';'; - } - if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF - && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF - /* But globs are already references (kinda) */ - && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF - ) { - str[n++] = '\\'; - } - if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF - && !scalar_mod_type(NULL, i)) { - str[n++] = '['; - str[n++] = '$'; - str[n++] = '@'; - str[n++] = '%'; - if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; - str[n++] = '*'; - str[n++] = ']'; - } - else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; - if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { - str[n-1] = '_'; defgv = 0; - } - oa = oa >> 4; + if (oa & OA_OPTIONAL && !seen_question && ( + !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF + )) { + seen_question = 1; + str[n++] = ';'; + } + if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF + && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF + /* But globs are already references (kinda) */ + && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF + ) { + str[n++] = '\\'; + } + if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF + && !scalar_mod_type(NULL, i)) { + str[n++] = '['; + str[n++] = '$'; + str[n++] = '@'; + str[n++] = '%'; + if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&'; + str[n++] = '*'; + str[n++] = ']'; + } + else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; + if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') { + str[n-1] = '_'; defgv = 0; + } + oa = oa >> 4; } if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';'; str[n++] = '\0'; @@ -18300,72 +18652,72 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, switch(opnum) { case 0: - return op_append_elem(OP_LINESEQ, - argop, - newSLICEOP(0, - newSVOP(OP_CONST, 0, newSViv(-code % 3)), - newOP(OP_CALLER,0) - ) - ); + return op_append_elem(OP_LINESEQ, + argop, + newSLICEOP(0, + newSVOP(OP_CONST, 0, newSViv(-code % 3)), + newOP(OP_CALLER,0) + ) + ); case OP_EACH: case OP_KEYS: case OP_VALUES: - o = newUNOP(OP_AVHVSWITCH,0,argop); - o->op_private = opnum-OP_EACH; - return o; + o = newUNOP(OP_AVHVSWITCH,0,argop); + o->op_private = opnum-OP_EACH; + return o; case OP_SELECT: /* which represents OP_SSELECT as well */ - if (code) - return newCONDOP( - 0, - newBINOP(OP_GT, 0, - newAVREF(newGVOP(OP_GV, 0, PL_defgv)), - newSVOP(OP_CONST, 0, newSVuv(1)) - ), - coresub_op(newSVuv((UV)OP_SSELECT), 0, - OP_SSELECT), - coresub_op(coreargssv, 0, OP_SELECT) - ); - /* FALLTHROUGH */ + if (code) + return newCONDOP( + 0, + newBINOP(OP_GT, 0, + newAVREF(newGVOP(OP_GV, 0, PL_defgv)), + newSVOP(OP_CONST, 0, newSVuv(1)) + ), + coresub_op(newSVuv((UV)OP_SSELECT), 0, + OP_SSELECT), + coresub_op(coreargssv, 0, OP_SELECT) + ); + /* FALLTHROUGH */ default: - switch (PL_opargs[opnum] & OA_CLASS_MASK) { - case OA_BASEOP: - return op_append_elem( - OP_LINESEQ, argop, - newOP(opnum, - opnum == OP_WANTARRAY || opnum == OP_RUNCV - ? OPpOFFBYONE << 8 : 0) - ); - case OA_BASEOP_OR_UNOP: - if (opnum == OP_ENTEREVAL) { - o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); - if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; - } - else o = newUNOP(opnum,0,argop); - if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; - else { - onearg: - if (is_handle_constructor(o, 1)) - argop->op_private |= OPpCOREARGS_DEREF1; - if (scalar_mod_type(NULL, opnum)) - argop->op_private |= OPpCOREARGS_SCALARMOD; - } - return o; - default: - o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); - if (is_handle_constructor(o, 2)) - argop->op_private |= OPpCOREARGS_DEREF2; - if (opnum == OP_SUBSTR) { - o->op_private |= OPpMAYBE_LVSUB; - return o; - } - else goto onearg; - } + switch (PL_opargs[opnum] & OA_CLASS_MASK) { + case OA_BASEOP: + return op_append_elem( + OP_LINESEQ, argop, + newOP(opnum, + opnum == OP_WANTARRAY || opnum == OP_RUNCV + ? OPpOFFBYONE << 8 : 0) + ); + case OA_BASEOP_OR_UNOP: + if (opnum == OP_ENTEREVAL) { + o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); + if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; + } + else o = newUNOP(opnum,0,argop); + if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; + else { + onearg: + if (is_handle_constructor(o, 1)) + argop->op_private |= OPpCOREARGS_DEREF1; + if (scalar_mod_type(NULL, opnum)) + argop->op_private |= OPpCOREARGS_SCALARMOD; + } + return o; + default: + o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop); + if (is_handle_constructor(o, 2)) + argop->op_private |= OPpCOREARGS_DEREF2; + if (opnum == OP_SUBSTR) { + o->op_private |= OPpMAYBE_LVSUB; + return o; + } + else goto onearg; + } } } void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, - SV * const *new_const_svp) + SV * const *new_const_svp) { const char *hvname; bool is_const = !!CvCONST(old_cv); @@ -18374,36 +18726,36 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; if (is_const && new_const_svp && old_const_sv == *new_const_svp) - return; - /* They are 2 constant subroutines generated from - the same constant. This probably means that - they are really the "same" proxy subroutine - instantiated in 2 places. Most likely this is - when a constant is exported twice. Don't warn. - */ + return; + /* They are 2 constant subroutines generated from + the same constant. This probably means that + they are really the "same" proxy subroutine + instantiated in 2 places. Most likely this is + when a constant is exported twice. Don't warn. + */ if ( - (ckWARN(WARN_REDEFINE) - && !( - CvGV(old_cv) && GvSTASH(CvGV(old_cv)) - && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 - && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), - strEQ(hvname, "autouse")) - ) - ) + (ckWARN(WARN_REDEFINE) + && !( + CvGV(old_cv) && GvSTASH(CvGV(old_cv)) + && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 + && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), + strEQ(hvname, "autouse")) + ) + ) || (is_const - && ckWARN_d(WARN_REDEFINE) - && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) - ) + && ckWARN_d(WARN_REDEFINE) + && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) + ) ) - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - is_const - ? "Constant subroutine %" SVf " redefined" - : "Subroutine %" SVf " redefined", - SVfARG(name)); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + is_const + ? "Constant subroutine %" SVf " redefined" + : "Subroutine %" SVf " redefined", + SVfARG(name)); } /* -=head1 Hook manipulation +=for apidoc_section $hook These functions provide convenient and thread-safe means of manipulating hook variables. @@ -18449,13 +18801,13 @@ something like this: static Perl_check_t nxck_frob; static OP *myck_frob(pTHX_ OP *op) { - ... - op = nxck_frob(aTHX_ op); - ... - return op; + ... + op = nxck_frob(aTHX_ op); + ... + return op; } BOOT: - wrap_op_checker(OP_FROB, myck_frob, &nxck_frob); + wrap_op_checker(OP_FROB, myck_frob, &nxck_frob); If you want to influence compilation of calls to a specific subroutine, then use L rather than hooking checking of @@ -18468,15 +18820,14 @@ void Perl_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p) { - dVAR; PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_WRAP_OP_CHECKER; if (*old_checker_p) return; OP_CHECK_MUTEX_LOCK; if (!*old_checker_p) { - *old_checker_p = PL_check[opcode]; - PL_check[opcode] = new_checker; + *old_checker_p = PL_check[opcode]; + PL_check[opcode] = new_checker; } OP_CHECK_MUTEX_UNLOCK; } @@ -18491,7 +18842,7 @@ const_sv_xsub(pTHX_ CV* cv) SV *const sv = MUTABLE_SV(XSANY.any_ptr); PERL_UNUSED_ARG(items); if (!sv) { - XSRETURN(0); + XSRETURN(0); } EXTEND(sp, 1); ST(0) = sv; @@ -18507,15 +18858,15 @@ const_av_xsub(pTHX_ CV* cv) assert(av); #ifndef DEBUGGING if (!av) { - XSRETURN(0); + XSRETURN(0); } #endif if (SvRMAGICAL(av)) - Perl_croak(aTHX_ "Magical list constants are not supported"); - if (GIMME_V != G_ARRAY) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); - XSRETURN(1); + Perl_croak(aTHX_ "Magical list constants are not supported"); + if (GIMME_V != G_LIST) { + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); + XSRETURN(1); } EXTEND(SP, AvFILLp(av)+1); Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);