This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow my \$a
[perl5.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * Note that during the build of miniperl, a temporary copy of this file
26  * is made, called opmini.c.
27  *
28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
29  *  * structural OP pointers to its children and siblings (op_sibling,
30  *    op_first etc) that define the tree structure;
31  *  * execution order OP pointers (op_next, plus sometimes op_other,
32  *    op_lastop  etc) that define the execution sequence plus variants;
33  *  * a pointer to the C "pp" function that would execute the op;
34  *  * any data specific to that op.
35  * For example, an OP_CONST op points to the pp_const() function and to an
36  * SV containing the constant value. When pp_const() is executed, its job
37  * is to push that SV onto the stack.
38  *
39  * OPs are mainly created by the newFOO() functions, which are mainly
40  * called from the parser (in perly.y) as the code is parsed. For example
41  * the Perl code $a + $b * $c would cause the equivalent of the following
42  * to be called (oversimplifying a bit):
43  *
44  *  newBINOP(OP_ADD, flags,
45  *      newSVREF($a),
46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47  *  )
48  *
49  * As the parser reduces low-level rules, it creates little op subtrees;
50  * as higher-level rules are resolved, these subtrees get joined together
51  * as branches on a bigger subtree, until eventually a top-level rule like
52  * a subroutine definition is reduced, at which point there is one large
53  * parse tree left.
54  *
55  * The execution order pointers (op_next) are generated as the subtrees
56  * are joined together. Consider this sub-expression: A*B + C/D: at the
57  * point when it's just been parsed, the op tree looks like:
58  *
59  *   [+]
60  *    |
61  *   [*]------[/]
62  *    |        |
63  *    A---B    C---D
64  *
65  * with the intended execution order being:
66  *
67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
68  *
69  * At this point all the nodes' op_next pointers will have been set,
70  * except that:
71  *    * we don't know what the [NEXT] node will be yet;
72  *    * we don't know what the [PREV] node will be yet, but when it gets
73  *      created and needs its op_next set, it needs to be set to point to
74  *      A, which is non-obvious.
75  * To handle both those cases, we temporarily set the top node's
76  * op_next to point to the first node to be executed in this subtree (A in
77  * this case). This means that initially a subtree's op_next chain,
78  * starting from the top node, will visit each node in execution sequence
79  * then point back at the top node.
80  * When we embed this subtree in a larger tree, its top op_next is used
81  * to get the start node, then is set to point to its new neighbour.
82  * For example the two separate [*],A,B and [/],C,D subtrees would
83  * initially have had:
84  *   [*] => A;  A => B;  B => [*]
85  * and
86  *   [/] => C;  C => D;  D => [/]
87  * When these two subtrees were joined together to make the [+] subtree,
88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89  * set to point to [/]'s op_next, i.e. C.
90  *
91  * This op_next linking is done by the LINKLIST() macro and its underlying
92  * op_linklist() function. Given a top-level op, if its op_next is
93  * non-null, it's already been linked, so leave it. Otherwise link it with
94  * its children as described above, possibly recursively if any of the
95  * children have a null op_next.
96  *
97  * In summary: given a subtree, its top-level node's op_next will either
98  * be:
99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
100  *   fake: points to the start op for this subtree;
101  *   real: once the subtree has been embedded into a larger tree
102  */
103
104 /*
105
106 Here's an older description from Larry.
107
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110     A bottom-up pass
111     A top-down pass
112     An execution-order pass
113
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines.  The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order.  (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again).  As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node.  But
130 it's still not the real execution order.
131
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer.  At that point, we can call
135 into peep() to do that code's portion of the 3rd pass.  It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140    get the compile time state of %^H for that block.  Storing %^H in every
141    block (or even COP) would be very expensive, so a different approach is
142    taken.  The (running) state of %^H is serialised into a tree of HE-like
143    structs.  Stores into %^H are chained onto the current leaf as a struct
144    refcounted_he * with the key and the value.  Deletes from %^H are saved
145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
146    turned back into a regular HV by walking back up the tree from that point's
147    leaf, ignoring any key you've already seen (placeholder or not), storing
148    the rest into the HV structure, then removing the placeholders. Hence
149    memory is only used to store the %^H deltas from the enclosing COP, rather
150    than the entire %^H on each COP.
151
152    To cause actions on %^H to write out the serialisation records, it has
153    magic type 'H'. This magic (itself) does nothing, but its presence causes
154    the values to gain magic type 'h', which has entries for set and clear.
155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158    it will be correctly restored when any inner compiling scope is exited.
159 */
160
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173
174 /* Used to avoid recursion through the op tree in scalarvoid() and
175    op_free()
176 */
177
178 #define DEFERRED_OP_STEP 100
179 #define DEFER_OP(o) \
180   STMT_START { \
181     if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) {    \
182         defer_stack_alloc += DEFERRED_OP_STEP; \
183         assert(defer_stack_alloc > 0); \
184         Renew(defer_stack, defer_stack_alloc, OP *); \
185     } \
186     defer_stack[++defer_ix] = o; \
187   } STMT_END
188
189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
190
191 /* remove any leading "empty" ops from the op_next chain whose first
192  * node's address is stored in op_p. Store the updated address of the
193  * first node in op_p.
194  */
195
196 STATIC void
197 S_prune_chain_head(OP** op_p)
198 {
199     while (*op_p
200         && (   (*op_p)->op_type == OP_NULL
201             || (*op_p)->op_type == OP_SCOPE
202             || (*op_p)->op_type == OP_SCALAR
203             || (*op_p)->op_type == OP_LINESEQ)
204     )
205         *op_p = (*op_p)->op_next;
206 }
207
208
209 /* See the explanatory comments above struct opslab in op.h. */
210
211 #ifdef PERL_DEBUG_READONLY_OPS
212 #  define PERL_SLAB_SIZE 128
213 #  define PERL_MAX_SLAB_SIZE 4096
214 #  include <sys/mman.h>
215 #endif
216
217 #ifndef PERL_SLAB_SIZE
218 #  define PERL_SLAB_SIZE 64
219 #endif
220 #ifndef PERL_MAX_SLAB_SIZE
221 #  define PERL_MAX_SLAB_SIZE 2048
222 #endif
223
224 /* rounds up to nearest pointer */
225 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
226 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
227
228 static OPSLAB *
229 S_new_slab(pTHX_ size_t sz)
230 {
231 #ifdef PERL_DEBUG_READONLY_OPS
232     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
233                                    PROT_READ|PROT_WRITE,
234                                    MAP_ANON|MAP_PRIVATE, -1, 0);
235     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
236                           (unsigned long) sz, slab));
237     if (slab == MAP_FAILED) {
238         perror("mmap failed");
239         abort();
240     }
241     slab->opslab_size = (U16)sz;
242 #else
243     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
244 #endif
245 #ifndef WIN32
246     /* The context is unused in non-Windows */
247     PERL_UNUSED_CONTEXT;
248 #endif
249     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
250     return slab;
251 }
252
253 /* requires double parens and aTHX_ */
254 #define DEBUG_S_warn(args)                                             \
255     DEBUG_S(                                                            \
256         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
257     )
258
259 void *
260 Perl_Slab_Alloc(pTHX_ size_t sz)
261 {
262     OPSLAB *slab;
263     OPSLAB *slab2;
264     OPSLOT *slot;
265     OP *o;
266     size_t opsz, space;
267
268     /* We only allocate ops from the slab during subroutine compilation.
269        We find the slab via PL_compcv, hence that must be non-NULL. It could
270        also be pointing to a subroutine which is now fully set up (CvROOT()
271        pointing to the top of the optree for that sub), or a subroutine
272        which isn't using the slab allocator. If our sanity checks aren't met,
273        don't use a slab, but allocate the OP directly from the heap.  */
274     if (!PL_compcv || CvROOT(PL_compcv)
275      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
276     {
277         o = (OP*)PerlMemShared_calloc(1, sz);
278         goto gotit;
279     }
280
281     /* While the subroutine is under construction, the slabs are accessed via
282        CvSTART(), to avoid needing to expand PVCV by one pointer for something
283        unneeded at runtime. Once a subroutine is constructed, the slabs are
284        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
285        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
286        details.  */
287     if (!CvSTART(PL_compcv)) {
288         CvSTART(PL_compcv) =
289             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
290         CvSLABBED_on(PL_compcv);
291         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
292     }
293     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
294
295     opsz = SIZE_TO_PSIZE(sz);
296     sz = opsz + OPSLOT_HEADER_P;
297
298     /* The slabs maintain a free list of OPs. In particular, constant folding
299        will free up OPs, so it makes sense to re-use them where possible. A
300        freed up slot is used in preference to a new allocation.  */
301     if (slab->opslab_freed) {
302         OP **too = &slab->opslab_freed;
303         o = *too;
304         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
305         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
306             DEBUG_S_warn((aTHX_ "Alas! too small"));
307             o = *(too = &o->op_next);
308             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
309         }
310         if (o) {
311             *too = o->op_next;
312             Zero(o, opsz, I32 *);
313             o->op_slabbed = 1;
314             goto gotit;
315         }
316     }
317
318 #define INIT_OPSLOT \
319             slot->opslot_slab = slab;                   \
320             slot->opslot_next = slab2->opslab_first;    \
321             slab2->opslab_first = slot;                 \
322             o = &slot->opslot_op;                       \
323             o->op_slabbed = 1
324
325     /* The partially-filled slab is next in the chain. */
326     slab2 = slab->opslab_next ? slab->opslab_next : slab;
327     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
328         /* Remaining space is too small. */
329
330         /* If we can fit a BASEOP, add it to the free chain, so as not
331            to waste it. */
332         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
333             slot = &slab2->opslab_slots;
334             INIT_OPSLOT;
335             o->op_type = OP_FREED;
336             o->op_next = slab->opslab_freed;
337             slab->opslab_freed = o;
338         }
339
340         /* Create a new slab.  Make this one twice as big. */
341         slot = slab2->opslab_first;
342         while (slot->opslot_next) slot = slot->opslot_next;
343         slab2 = S_new_slab(aTHX_
344                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
345                                         ? PERL_MAX_SLAB_SIZE
346                                         : (DIFF(slab2, slot)+1)*2);
347         slab2->opslab_next = slab->opslab_next;
348         slab->opslab_next = slab2;
349     }
350     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
351
352     /* Create a new op slot */
353     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
354     assert(slot >= &slab2->opslab_slots);
355     if (DIFF(&slab2->opslab_slots, slot)
356          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
357         slot = &slab2->opslab_slots;
358     INIT_OPSLOT;
359     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
360
361   gotit:
362 #ifdef PERL_OP_PARENT
363     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
364     assert(!o->op_moresib);
365     assert(!o->op_sibparent);
366 #endif
367
368     return (void *)o;
369 }
370
371 #undef INIT_OPSLOT
372
373 #ifdef PERL_DEBUG_READONLY_OPS
374 void
375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
376 {
377     PERL_ARGS_ASSERT_SLAB_TO_RO;
378
379     if (slab->opslab_readonly) return;
380     slab->opslab_readonly = 1;
381     for (; slab; slab = slab->opslab_next) {
382         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
383                               (unsigned long) slab->opslab_size, slab));*/
384         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
385             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
386                              (unsigned long)slab->opslab_size, errno);
387     }
388 }
389
390 void
391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
392 {
393     OPSLAB *slab2;
394
395     PERL_ARGS_ASSERT_SLAB_TO_RW;
396
397     if (!slab->opslab_readonly) return;
398     slab2 = slab;
399     for (; slab2; slab2 = slab2->opslab_next) {
400         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
401                               (unsigned long) size, slab2));*/
402         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
403                      PROT_READ|PROT_WRITE)) {
404             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
405                              (unsigned long)slab2->opslab_size, errno);
406         }
407     }
408     slab->opslab_readonly = 0;
409 }
410
411 #else
412 #  define Slab_to_rw(op)    NOOP
413 #endif
414
415 /* This cannot possibly be right, but it was copied from the old slab
416    allocator, to which it was originally added, without explanation, in
417    commit 083fcd5. */
418 #ifdef NETWARE
419 #    define PerlMemShared PerlMem
420 #endif
421
422 void
423 Perl_Slab_Free(pTHX_ void *op)
424 {
425     OP * const o = (OP *)op;
426     OPSLAB *slab;
427
428     PERL_ARGS_ASSERT_SLAB_FREE;
429
430     if (!o->op_slabbed) {
431         if (!o->op_static)
432             PerlMemShared_free(op);
433         return;
434     }
435
436     slab = OpSLAB(o);
437     /* If this op is already freed, our refcount will get screwy. */
438     assert(o->op_type != OP_FREED);
439     o->op_type = OP_FREED;
440     o->op_next = slab->opslab_freed;
441     slab->opslab_freed = o;
442     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
443     OpslabREFCNT_dec_padok(slab);
444 }
445
446 void
447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
448 {
449     const bool havepad = !!PL_comppad;
450     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
451     if (havepad) {
452         ENTER;
453         PAD_SAVE_SETNULLPAD();
454     }
455     opslab_free(slab);
456     if (havepad) LEAVE;
457 }
458
459 void
460 Perl_opslab_free(pTHX_ OPSLAB *slab)
461 {
462     OPSLAB *slab2;
463     PERL_ARGS_ASSERT_OPSLAB_FREE;
464     PERL_UNUSED_CONTEXT;
465     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
466     assert(slab->opslab_refcnt == 1);
467     do {
468         slab2 = slab->opslab_next;
469 #ifdef DEBUGGING
470         slab->opslab_refcnt = ~(size_t)0;
471 #endif
472 #ifdef PERL_DEBUG_READONLY_OPS
473         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
474                                                (void*)slab));
475         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
476             perror("munmap failed");
477             abort();
478         }
479 #else
480         PerlMemShared_free(slab);
481 #endif
482         slab = slab2;
483     } while (slab);
484 }
485
486 void
487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
488 {
489     OPSLAB *slab2;
490     OPSLOT *slot;
491 #ifdef DEBUGGING
492     size_t savestack_count = 0;
493 #endif
494     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
495     slab2 = slab;
496     do {
497         for (slot = slab2->opslab_first;
498              slot->opslot_next;
499              slot = slot->opslot_next) {
500             if (slot->opslot_op.op_type != OP_FREED
501              && !(slot->opslot_op.op_savefree
502 #ifdef DEBUGGING
503                   && ++savestack_count
504 #endif
505                  )
506             ) {
507                 assert(slot->opslot_op.op_slabbed);
508                 op_free(&slot->opslot_op);
509                 if (slab->opslab_refcnt == 1) goto free;
510             }
511         }
512     } while ((slab2 = slab2->opslab_next));
513     /* > 1 because the CV still holds a reference count. */
514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
515 #ifdef DEBUGGING
516         assert(savestack_count == slab->opslab_refcnt-1);
517 #endif
518         /* Remove the CV’s reference count. */
519         slab->opslab_refcnt--;
520         return;
521     }
522    free:
523     opslab_free(slab);
524 }
525
526 #ifdef PERL_DEBUG_READONLY_OPS
527 OP *
528 Perl_op_refcnt_inc(pTHX_ OP *o)
529 {
530     if(o) {
531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532         if (slab && slab->opslab_readonly) {
533             Slab_to_rw(slab);
534             ++o->op_targ;
535             Slab_to_ro(slab);
536         } else {
537             ++o->op_targ;
538         }
539     }
540     return o;
541
542 }
543
544 PADOFFSET
545 Perl_op_refcnt_dec(pTHX_ OP *o)
546 {
547     PADOFFSET result;
548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
549
550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
551
552     if (slab && slab->opslab_readonly) {
553         Slab_to_rw(slab);
554         result = --o->op_targ;
555         Slab_to_ro(slab);
556     } else {
557         result = --o->op_targ;
558     }
559     return result;
560 }
561 #endif
562 /*
563  * In the following definition, the ", (OP*)0" is just to make the compiler
564  * think the expression is of the right type: croak actually does a Siglongjmp.
565  */
566 #define CHECKOP(type,o) \
567     ((PL_op_mask && PL_op_mask[type])                           \
568      ? ( op_free((OP*)o),                                       \
569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
570          (OP*)0 )                                               \
571      : PL_check[type](aTHX_ (OP*)o))
572
573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
574
575 #define OpTYPE_set(o,type) \
576     STMT_START {                                \
577         o->op_type = (OPCODE)type;              \
578         o->op_ppaddr = PL_ppaddr[type];         \
579     } STMT_END
580
581 STATIC OP *
582 S_no_fh_allowed(pTHX_ OP *o)
583 {
584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
585
586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
587                  OP_DESC(o)));
588     return o;
589 }
590
591 STATIC OP *
592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
593 {
594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
596     return o;
597 }
598  
599 STATIC OP *
600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
601 {
602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
603
604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
605     return o;
606 }
607
608 STATIC void
609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
610 {
611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
612
613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
615 }
616
617 /* remove flags var, its unused in all callers, move to to right end since gv
618   and kid are always the same */
619 STATIC void
620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
621 {
622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
624  
625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
627 }
628
629 STATIC void
630 S_no_bareword_allowed(pTHX_ OP *o)
631 {
632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
633
634     qerror(Perl_mess(aTHX_
635                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
636                      SVfARG(cSVOPo_sv)));
637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
638 }
639
640 /* "register" allocation */
641
642 PADOFFSET
643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
644 {
645     PADOFFSET off;
646     const bool is_our = (PL_parser->in_my == KEY_our);
647
648     PERL_ARGS_ASSERT_ALLOCMY;
649
650     if (flags & ~SVf_UTF8)
651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
652                    (UV)flags);
653
654     /* complain about "my $<special_var>" etc etc */
655     if (len &&
656         !(is_our ||
657           isALPHA(name[1]) ||
658           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
659           (name[1] == '_' && len > 2)))
660     {
661         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
662          && isASCII(name[1])
663          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
664             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
665                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
666                               PL_parser->in_my == KEY_state ? "state" : "my"));
667         } else {
668             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
669                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
670         }
671     }
672
673     /* allocate a spare slot and store the name in that slot */
674
675     off = pad_add_name_pvn(name, len,
676                        (is_our ? padadd_OUR :
677                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
678                     PL_parser->in_my_stash,
679                     (is_our
680                         /* $_ is always in main::, even with our */
681                         ? (PL_curstash && !memEQs(name,len,"$_")
682                             ? PL_curstash
683                             : PL_defstash)
684                         : NULL
685                     )
686     );
687     /* anon sub prototypes contains state vars should always be cloned,
688      * otherwise the state var would be shared between anon subs */
689
690     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
691         CvCLONE_on(PL_compcv);
692
693     return off;
694 }
695
696 /*
697 =head1 Optree Manipulation Functions
698
699 =for apidoc alloccopstash
700
701 Available only under threaded builds, this function allocates an entry in
702 C<PL_stashpad> for the stash passed to it.
703
704 =cut
705 */
706
707 #ifdef USE_ITHREADS
708 PADOFFSET
709 Perl_alloccopstash(pTHX_ HV *hv)
710 {
711     PADOFFSET off = 0, o = 1;
712     bool found_slot = FALSE;
713
714     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
715
716     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
717
718     for (; o < PL_stashpadmax; ++o) {
719         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
720         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
721             found_slot = TRUE, off = o;
722     }
723     if (!found_slot) {
724         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
725         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
726         off = PL_stashpadmax;
727         PL_stashpadmax += 10;
728     }
729
730     PL_stashpad[PL_stashpadix = off] = hv;
731     return off;
732 }
733 #endif
734
735 /* free the body of an op without examining its contents.
736  * Always use this rather than FreeOp directly */
737
738 static void
739 S_op_destroy(pTHX_ OP *o)
740 {
741     FreeOp(o);
742 }
743
744 /* Destructor */
745
746 /*
747 =for apidoc Am|void|op_free|OP *o
748
749 Free an op.  Only use this when an op is no longer linked to from any
750 optree.
751
752 =cut
753 */
754
755 void
756 Perl_op_free(pTHX_ OP *o)
757 {
758     dVAR;
759     OPCODE type;
760     SSize_t defer_ix = -1;
761     SSize_t defer_stack_alloc = 0;
762     OP **defer_stack = NULL;
763
764     do {
765
766         /* Though ops may be freed twice, freeing the op after its slab is a
767            big no-no. */
768         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
769         /* During the forced freeing of ops after compilation failure, kidops
770            may be freed before their parents. */
771         if (!o || o->op_type == OP_FREED)
772             continue;
773
774         type = o->op_type;
775
776         /* an op should only ever acquire op_private flags that we know about.
777          * If this fails, you may need to fix something in regen/op_private.
778          * Don't bother testing if:
779          *   * the op_ppaddr doesn't match the op; someone may have
780          *     overridden the op and be doing strange things with it;
781          *   * we've errored, as op flags are often left in an
782          *     inconsistent state then. Note that an error when
783          *     compiling the main program leaves PL_parser NULL, so
784          *     we can't spot faults in the main code, only
785          *     evaled/required code */
786 #ifdef DEBUGGING
787         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
788             && PL_parser
789             && !PL_parser->error_count)
790         {
791             assert(!(o->op_private & ~PL_op_private_valid[type]));
792         }
793 #endif
794
795         if (o->op_private & OPpREFCOUNTED) {
796             switch (type) {
797             case OP_LEAVESUB:
798             case OP_LEAVESUBLV:
799             case OP_LEAVEEVAL:
800             case OP_LEAVE:
801             case OP_SCOPE:
802             case OP_LEAVEWRITE:
803                 {
804                 PADOFFSET refcnt;
805                 OP_REFCNT_LOCK;
806                 refcnt = OpREFCNT_dec(o);
807                 OP_REFCNT_UNLOCK;
808                 if (refcnt) {
809                     /* Need to find and remove any pattern match ops from the list
810                        we maintain for reset().  */
811                     find_and_forget_pmops(o);
812                     continue;
813                 }
814                 }
815                 break;
816             default:
817                 break;
818             }
819         }
820
821         /* Call the op_free hook if it has been set. Do it now so that it's called
822          * at the right time for refcounted ops, but still before all of the kids
823          * are freed. */
824         CALL_OPFREEHOOK(o);
825
826         if (o->op_flags & OPf_KIDS) {
827             OP *kid, *nextkid;
828             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
829                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
830                 if (!kid || kid->op_type == OP_FREED)
831                     /* During the forced freeing of ops after
832                        compilation failure, kidops may be freed before
833                        their parents. */
834                     continue;
835                 if (!(kid->op_flags & OPf_KIDS))
836                     /* If it has no kids, just free it now */
837                     op_free(kid);
838                 else
839                     DEFER_OP(kid);
840             }
841         }
842         if (type == OP_NULL)
843             type = (OPCODE)o->op_targ;
844
845         if (o->op_slabbed)
846             Slab_to_rw(OpSLAB(o));
847
848         /* COP* is not cleared by op_clear() so that we may track line
849          * numbers etc even after null() */
850         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
851             cop_free((COP*)o);
852         }
853
854         op_clear(o);
855         FreeOp(o);
856 #ifdef DEBUG_LEAKING_SCALARS
857         if (PL_op == o)
858             PL_op = NULL;
859 #endif
860     } while ( (o = POP_DEFERRED_OP()) );
861
862     Safefree(defer_stack);
863 }
864
865 /* S_op_clear_gv(): free a GV attached to an OP */
866
867 STATIC
868 #ifdef USE_ITHREADS
869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
870 #else
871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
872 #endif
873 {
874
875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
876             || o->op_type == OP_MULTIDEREF)
877 #ifdef USE_ITHREADS
878                 && PL_curpad
879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
880 #else
881                 ? (GV*)(*svp) : NULL;
882 #endif
883     /* It's possible during global destruction that the GV is freed
884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
886        will trigger an assertion failure, because the entry to sv_clear
887        checks that the scalar is not already freed.  A check of for
888        !SvIS_FREED(gv) turns out to be invalid, because during global
889        destruction the reference count can be forced down to zero
890        (with SVf_BREAK set).  In which case raising to 1 and then
891        dropping to 0 triggers cleanup before it should happen.  I
892        *think* that this might actually be a general, systematic,
893        weakness of the whole idea of SVf_BREAK, in that code *is*
894        allowed to raise and lower references during global destruction,
895        so any *valid* code that happens to do this during global
896        destruction might well trigger premature cleanup.  */
897     bool still_valid = gv && SvREFCNT(gv);
898
899     if (still_valid)
900         SvREFCNT_inc_simple_void(gv);
901 #ifdef USE_ITHREADS
902     if (*ixp > 0) {
903         pad_swipe(*ixp, TRUE);
904         *ixp = 0;
905     }
906 #else
907     SvREFCNT_dec(*svp);
908     *svp = NULL;
909 #endif
910     if (still_valid) {
911         int try_downgrade = SvREFCNT(gv) == 2;
912         SvREFCNT_dec_NN(gv);
913         if (try_downgrade)
914             gv_try_downgrade(gv);
915     }
916 }
917
918
919 void
920 Perl_op_clear(pTHX_ OP *o)
921 {
922
923     dVAR;
924
925     PERL_ARGS_ASSERT_OP_CLEAR;
926
927     switch (o->op_type) {
928     case OP_NULL:       /* Was holding old type, if any. */
929         /* FALLTHROUGH */
930     case OP_ENTERTRY:
931     case OP_ENTEREVAL:  /* Was holding hints. */
932         o->op_targ = 0;
933         break;
934     default:
935         if (!(o->op_flags & OPf_REF)
936             || (PL_check[o->op_type] != Perl_ck_ftst))
937             break;
938         /* FALLTHROUGH */
939     case OP_GVSV:
940     case OP_GV:
941     case OP_AELEMFAST:
942 #ifdef USE_ITHREADS
943             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
944 #else
945             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
946 #endif
947         break;
948     case OP_METHOD_REDIR:
949     case OP_METHOD_REDIR_SUPER:
950 #ifdef USE_ITHREADS
951         if (cMETHOPx(o)->op_rclass_targ) {
952             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
953             cMETHOPx(o)->op_rclass_targ = 0;
954         }
955 #else
956         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
957         cMETHOPx(o)->op_rclass_sv = NULL;
958 #endif
959     case OP_METHOD_NAMED:
960     case OP_METHOD_SUPER:
961         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
962         cMETHOPx(o)->op_u.op_meth_sv = NULL;
963 #ifdef USE_ITHREADS
964         if (o->op_targ) {
965             pad_swipe(o->op_targ, 1);
966             o->op_targ = 0;
967         }
968 #endif
969         break;
970     case OP_CONST:
971     case OP_HINTSEVAL:
972         SvREFCNT_dec(cSVOPo->op_sv);
973         cSVOPo->op_sv = NULL;
974 #ifdef USE_ITHREADS
975         /** Bug #15654
976           Even if op_clear does a pad_free for the target of the op,
977           pad_free doesn't actually remove the sv that exists in the pad;
978           instead it lives on. This results in that it could be reused as 
979           a target later on when the pad was reallocated.
980         **/
981         if(o->op_targ) {
982           pad_swipe(o->op_targ,1);
983           o->op_targ = 0;
984         }
985 #endif
986         break;
987     case OP_DUMP:
988     case OP_GOTO:
989     case OP_NEXT:
990     case OP_LAST:
991     case OP_REDO:
992         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
993             break;
994         /* FALLTHROUGH */
995     case OP_TRANS:
996     case OP_TRANSR:
997         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
998             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
999 #ifdef USE_ITHREADS
1000             if (cPADOPo->op_padix > 0) {
1001                 pad_swipe(cPADOPo->op_padix, TRUE);
1002                 cPADOPo->op_padix = 0;
1003             }
1004 #else
1005             SvREFCNT_dec(cSVOPo->op_sv);
1006             cSVOPo->op_sv = NULL;
1007 #endif
1008         }
1009         else {
1010             PerlMemShared_free(cPVOPo->op_pv);
1011             cPVOPo->op_pv = NULL;
1012         }
1013         break;
1014     case OP_SUBST:
1015         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1016         goto clear_pmop;
1017     case OP_PUSHRE:
1018 #ifdef USE_ITHREADS
1019         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1020             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1021         }
1022 #else
1023         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1024 #endif
1025         /* FALLTHROUGH */
1026     case OP_MATCH:
1027     case OP_QR:
1028     clear_pmop:
1029         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1030             op_free(cPMOPo->op_code_list);
1031         cPMOPo->op_code_list = NULL;
1032         forget_pmop(cPMOPo);
1033         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1034         /* we use the same protection as the "SAFE" version of the PM_ macros
1035          * here since sv_clean_all might release some PMOPs
1036          * after PL_regex_padav has been cleared
1037          * and the clearing of PL_regex_padav needs to
1038          * happen before sv_clean_all
1039          */
1040 #ifdef USE_ITHREADS
1041         if(PL_regex_pad) {        /* We could be in destruction */
1042             const IV offset = (cPMOPo)->op_pmoffset;
1043             ReREFCNT_dec(PM_GETRE(cPMOPo));
1044             PL_regex_pad[offset] = &PL_sv_undef;
1045             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1046                            sizeof(offset));
1047         }
1048 #else
1049         ReREFCNT_dec(PM_GETRE(cPMOPo));
1050         PM_SETRE(cPMOPo, NULL);
1051 #endif
1052
1053         break;
1054
1055     case OP_MULTIDEREF:
1056         {
1057             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1058             UV actions = items->uv;
1059             bool last = 0;
1060             bool is_hash = FALSE;
1061
1062             while (!last) {
1063                 switch (actions & MDEREF_ACTION_MASK) {
1064
1065                 case MDEREF_reload:
1066                     actions = (++items)->uv;
1067                     continue;
1068
1069                 case MDEREF_HV_padhv_helem:
1070                     is_hash = TRUE;
1071                 case MDEREF_AV_padav_aelem:
1072                     pad_free((++items)->pad_offset);
1073                     goto do_elem;
1074
1075                 case MDEREF_HV_gvhv_helem:
1076                     is_hash = TRUE;
1077                 case MDEREF_AV_gvav_aelem:
1078 #ifdef USE_ITHREADS
1079                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1080 #else
1081                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1082 #endif
1083                     goto do_elem;
1084
1085                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1086                     is_hash = TRUE;
1087                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1088 #ifdef USE_ITHREADS
1089                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1090 #else
1091                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1092 #endif
1093                     goto do_vivify_rv2xv_elem;
1094
1095                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1096                     is_hash = TRUE;
1097                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1098                     pad_free((++items)->pad_offset);
1099                     goto do_vivify_rv2xv_elem;
1100
1101                 case MDEREF_HV_pop_rv2hv_helem:
1102                 case MDEREF_HV_vivify_rv2hv_helem:
1103                     is_hash = TRUE;
1104                 do_vivify_rv2xv_elem:
1105                 case MDEREF_AV_pop_rv2av_aelem:
1106                 case MDEREF_AV_vivify_rv2av_aelem:
1107                 do_elem:
1108                     switch (actions & MDEREF_INDEX_MASK) {
1109                     case MDEREF_INDEX_none:
1110                         last = 1;
1111                         break;
1112                     case MDEREF_INDEX_const:
1113                         if (is_hash) {
1114 #ifdef USE_ITHREADS
1115                             /* see RT #15654 */
1116                             pad_swipe((++items)->pad_offset, 1);
1117 #else
1118                             SvREFCNT_dec((++items)->sv);
1119 #endif
1120                         }
1121                         else
1122                             items++;
1123                         break;
1124                     case MDEREF_INDEX_padsv:
1125                         pad_free((++items)->pad_offset);
1126                         break;
1127                     case MDEREF_INDEX_gvsv:
1128 #ifdef USE_ITHREADS
1129                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1130 #else
1131                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1132 #endif
1133                         break;
1134                     }
1135
1136                     if (actions & MDEREF_FLAG_last)
1137                         last = 1;
1138                     is_hash = FALSE;
1139
1140                     break;
1141
1142                 default:
1143                     assert(0);
1144                     last = 1;
1145                     break;
1146
1147                 } /* switch */
1148
1149                 actions >>= MDEREF_SHIFT;
1150             } /* while */
1151
1152             /* start of malloc is at op_aux[-1], where the length is
1153              * stored */
1154             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1155         }
1156         break;
1157     }
1158
1159     if (o->op_targ > 0) {
1160         pad_free(o->op_targ);
1161         o->op_targ = 0;
1162     }
1163 }
1164
1165 STATIC void
1166 S_cop_free(pTHX_ COP* cop)
1167 {
1168     PERL_ARGS_ASSERT_COP_FREE;
1169
1170     CopFILE_free(cop);
1171     if (! specialWARN(cop->cop_warnings))
1172         PerlMemShared_free(cop->cop_warnings);
1173     cophh_free(CopHINTHASH_get(cop));
1174     if (PL_curcop == cop)
1175        PL_curcop = NULL;
1176 }
1177
1178 STATIC void
1179 S_forget_pmop(pTHX_ PMOP *const o
1180               )
1181 {
1182     HV * const pmstash = PmopSTASH(o);
1183
1184     PERL_ARGS_ASSERT_FORGET_PMOP;
1185
1186     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1187         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1188         if (mg) {
1189             PMOP **const array = (PMOP**) mg->mg_ptr;
1190             U32 count = mg->mg_len / sizeof(PMOP**);
1191             U32 i = count;
1192
1193             while (i--) {
1194                 if (array[i] == o) {
1195                     /* Found it. Move the entry at the end to overwrite it.  */
1196                     array[i] = array[--count];
1197                     mg->mg_len = count * sizeof(PMOP**);
1198                     /* Could realloc smaller at this point always, but probably
1199                        not worth it. Probably worth free()ing if we're the
1200                        last.  */
1201                     if(!count) {
1202                         Safefree(mg->mg_ptr);
1203                         mg->mg_ptr = NULL;
1204                     }
1205                     break;
1206                 }
1207             }
1208         }
1209     }
1210     if (PL_curpm == o) 
1211         PL_curpm = NULL;
1212 }
1213
1214 STATIC void
1215 S_find_and_forget_pmops(pTHX_ OP *o)
1216 {
1217     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1218
1219     if (o->op_flags & OPf_KIDS) {
1220         OP *kid = cUNOPo->op_first;
1221         while (kid) {
1222             switch (kid->op_type) {
1223             case OP_SUBST:
1224             case OP_PUSHRE:
1225             case OP_MATCH:
1226             case OP_QR:
1227                 forget_pmop((PMOP*)kid);
1228             }
1229             find_and_forget_pmops(kid);
1230             kid = OpSIBLING(kid);
1231         }
1232     }
1233 }
1234
1235 /*
1236 =for apidoc Am|void|op_null|OP *o
1237
1238 Neutralizes an op when it is no longer needed, but is still linked to from
1239 other ops.
1240
1241 =cut
1242 */
1243
1244 void
1245 Perl_op_null(pTHX_ OP *o)
1246 {
1247     dVAR;
1248
1249     PERL_ARGS_ASSERT_OP_NULL;
1250
1251     if (o->op_type == OP_NULL)
1252         return;
1253     op_clear(o);
1254     o->op_targ = o->op_type;
1255     OpTYPE_set(o, OP_NULL);
1256 }
1257
1258 void
1259 Perl_op_refcnt_lock(pTHX)
1260   PERL_TSA_ACQUIRE(PL_op_mutex)
1261 {
1262 #ifdef USE_ITHREADS
1263     dVAR;
1264 #endif
1265     PERL_UNUSED_CONTEXT;
1266     OP_REFCNT_LOCK;
1267 }
1268
1269 void
1270 Perl_op_refcnt_unlock(pTHX)
1271   PERL_TSA_RELEASE(PL_op_mutex)
1272 {
1273 #ifdef USE_ITHREADS
1274     dVAR;
1275 #endif
1276     PERL_UNUSED_CONTEXT;
1277     OP_REFCNT_UNLOCK;
1278 }
1279
1280
1281 /*
1282 =for apidoc op_sibling_splice
1283
1284 A general function for editing the structure of an existing chain of
1285 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1286 you to delete zero or more sequential nodes, replacing them with zero or
1287 more different nodes.  Performs the necessary op_first/op_last
1288 housekeeping on the parent node and op_sibling manipulation on the
1289 children.  The last deleted node will be marked as as the last node by
1290 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1291
1292 Note that op_next is not manipulated, and nodes are not freed; that is the
1293 responsibility of the caller.  It also won't create a new list op for an
1294 empty list etc; use higher-level functions like op_append_elem() for that.
1295
1296 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1297 the splicing doesn't affect the first or last op in the chain.
1298
1299 C<start> is the node preceding the first node to be spliced.  Node(s)
1300 following it will be deleted, and ops will be inserted after it.  If it is
1301 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1302 beginning.
1303
1304 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1305 If -1 or greater than or equal to the number of remaining kids, all
1306 remaining kids are deleted.
1307
1308 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1309 If C<NULL>, no nodes are inserted.
1310
1311 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1312 deleted.
1313
1314 For example:
1315
1316     action                    before      after         returns
1317     ------                    -----       -----         -------
1318
1319                               P           P
1320     splice(P, A, 2, X-Y-Z)    |           |             B-C
1321                               A-B-C-D     A-X-Y-Z-D
1322
1323                               P           P
1324     splice(P, NULL, 1, X-Y)   |           |             A
1325                               A-B-C-D     X-Y-B-C-D
1326
1327                               P           P
1328     splice(P, NULL, 3, NULL)  |           |             A-B-C
1329                               A-B-C-D     D
1330
1331                               P           P
1332     splice(P, B, 0, X-Y)      |           |             NULL
1333                               A-B-C-D     A-B-X-Y-C-D
1334
1335
1336 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1337 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1338
1339 =cut
1340 */
1341
1342 OP *
1343 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1344 {
1345     OP *first;
1346     OP *rest;
1347     OP *last_del = NULL;
1348     OP *last_ins = NULL;
1349
1350     if (start)
1351         first = OpSIBLING(start);
1352     else if (!parent)
1353         goto no_parent;
1354     else
1355         first = cLISTOPx(parent)->op_first;
1356
1357     assert(del_count >= -1);
1358
1359     if (del_count && first) {
1360         last_del = first;
1361         while (--del_count && OpHAS_SIBLING(last_del))
1362             last_del = OpSIBLING(last_del);
1363         rest = OpSIBLING(last_del);
1364         OpLASTSIB_set(last_del, NULL);
1365     }
1366     else
1367         rest = first;
1368
1369     if (insert) {
1370         last_ins = insert;
1371         while (OpHAS_SIBLING(last_ins))
1372             last_ins = OpSIBLING(last_ins);
1373         OpMAYBESIB_set(last_ins, rest, NULL);
1374     }
1375     else
1376         insert = rest;
1377
1378     if (start) {
1379         OpMAYBESIB_set(start, insert, NULL);
1380     }
1381     else {
1382         if (!parent)
1383             goto no_parent;
1384         cLISTOPx(parent)->op_first = insert;
1385         if (insert)
1386             parent->op_flags |= OPf_KIDS;
1387         else
1388             parent->op_flags &= ~OPf_KIDS;
1389     }
1390
1391     if (!rest) {
1392         /* update op_last etc */
1393         U32 type;
1394         OP *lastop;
1395
1396         if (!parent)
1397             goto no_parent;
1398
1399         /* ought to use OP_CLASS(parent) here, but that can't handle
1400          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1401          * either */
1402         type = parent->op_type;
1403         if (type == OP_CUSTOM) {
1404             dTHX;
1405             type = XopENTRYCUSTOM(parent, xop_class);
1406         }
1407         else {
1408             if (type == OP_NULL)
1409                 type = parent->op_targ;
1410             type = PL_opargs[type] & OA_CLASS_MASK;
1411         }
1412
1413         lastop = last_ins ? last_ins : start ? start : NULL;
1414         if (   type == OA_BINOP
1415             || type == OA_LISTOP
1416             || type == OA_PMOP
1417             || type == OA_LOOP
1418         )
1419             cLISTOPx(parent)->op_last = lastop;
1420
1421         if (lastop)
1422             OpLASTSIB_set(lastop, parent);
1423     }
1424     return last_del ? first : NULL;
1425
1426   no_parent:
1427     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1428 }
1429
1430
1431 #ifdef PERL_OP_PARENT
1432
1433 /*
1434 =for apidoc op_parent
1435
1436 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1437 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1438
1439 =cut
1440 */
1441
1442 OP *
1443 Perl_op_parent(OP *o)
1444 {
1445     PERL_ARGS_ASSERT_OP_PARENT;
1446     while (OpHAS_SIBLING(o))
1447         o = OpSIBLING(o);
1448     return o->op_sibparent;
1449 }
1450
1451 #endif
1452
1453
1454 /* replace the sibling following start with a new UNOP, which becomes
1455  * the parent of the original sibling; e.g.
1456  *
1457  *  op_sibling_newUNOP(P, A, unop-args...)
1458  *
1459  *  P              P
1460  *  |      becomes |
1461  *  A-B-C          A-U-C
1462  *                   |
1463  *                   B
1464  *
1465  * where U is the new UNOP.
1466  *
1467  * parent and start args are the same as for op_sibling_splice();
1468  * type and flags args are as newUNOP().
1469  *
1470  * Returns the new UNOP.
1471  */
1472
1473 STATIC OP *
1474 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1475 {
1476     OP *kid, *newop;
1477
1478     kid = op_sibling_splice(parent, start, 1, NULL);
1479     newop = newUNOP(type, flags, kid);
1480     op_sibling_splice(parent, start, 0, newop);
1481     return newop;
1482 }
1483
1484
1485 /* lowest-level newLOGOP-style function - just allocates and populates
1486  * the struct. Higher-level stuff should be done by S_new_logop() /
1487  * newLOGOP(). This function exists mainly to avoid op_first assignment
1488  * being spread throughout this file.
1489  */
1490
1491 STATIC LOGOP *
1492 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1493 {
1494     dVAR;
1495     LOGOP *logop;
1496     OP *kid = first;
1497     NewOp(1101, logop, 1, LOGOP);
1498     OpTYPE_set(logop, type);
1499     logop->op_first = first;
1500     logop->op_other = other;
1501     logop->op_flags = OPf_KIDS;
1502     while (kid && OpHAS_SIBLING(kid))
1503         kid = OpSIBLING(kid);
1504     if (kid)
1505         OpLASTSIB_set(kid, (OP*)logop);
1506     return logop;
1507 }
1508
1509
1510 /* Contextualizers */
1511
1512 /*
1513 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1514
1515 Applies a syntactic context to an op tree representing an expression.
1516 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1517 or C<G_VOID> to specify the context to apply.  The modified op tree
1518 is returned.
1519
1520 =cut
1521 */
1522
1523 OP *
1524 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1525 {
1526     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1527     switch (context) {
1528         case G_SCALAR: return scalar(o);
1529         case G_ARRAY:  return list(o);
1530         case G_VOID:   return scalarvoid(o);
1531         default:
1532             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1533                        (long) context);
1534     }
1535 }
1536
1537 /*
1538
1539 =for apidoc Am|OP*|op_linklist|OP *o
1540 This function is the implementation of the L</LINKLIST> macro.  It should
1541 not be called directly.
1542
1543 =cut
1544 */
1545
1546 OP *
1547 Perl_op_linklist(pTHX_ OP *o)
1548 {
1549     OP *first;
1550
1551     PERL_ARGS_ASSERT_OP_LINKLIST;
1552
1553     if (o->op_next)
1554         return o->op_next;
1555
1556     /* establish postfix order */
1557     first = cUNOPo->op_first;
1558     if (first) {
1559         OP *kid;
1560         o->op_next = LINKLIST(first);
1561         kid = first;
1562         for (;;) {
1563             OP *sibl = OpSIBLING(kid);
1564             if (sibl) {
1565                 kid->op_next = LINKLIST(sibl);
1566                 kid = sibl;
1567             } else {
1568                 kid->op_next = o;
1569                 break;
1570             }
1571         }
1572     }
1573     else
1574         o->op_next = o;
1575
1576     return o->op_next;
1577 }
1578
1579 static OP *
1580 S_scalarkids(pTHX_ OP *o)
1581 {
1582     if (o && o->op_flags & OPf_KIDS) {
1583         OP *kid;
1584         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1585             scalar(kid);
1586     }
1587     return o;
1588 }
1589
1590 STATIC OP *
1591 S_scalarboolean(pTHX_ OP *o)
1592 {
1593     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1594
1595     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1596          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1597         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1598          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1599          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1600         if (ckWARN(WARN_SYNTAX)) {
1601             const line_t oldline = CopLINE(PL_curcop);
1602
1603             if (PL_parser && PL_parser->copline != NOLINE) {
1604                 /* This ensures that warnings are reported at the first line
1605                    of the conditional, not the last.  */
1606                 CopLINE_set(PL_curcop, PL_parser->copline);
1607             }
1608             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1609             CopLINE_set(PL_curcop, oldline);
1610         }
1611     }
1612     return scalar(o);
1613 }
1614
1615 static SV *
1616 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1617 {
1618     assert(o);
1619     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1620            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1621     {
1622         const char funny  = o->op_type == OP_PADAV
1623                          || o->op_type == OP_RV2AV ? '@' : '%';
1624         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1625             GV *gv;
1626             if (cUNOPo->op_first->op_type != OP_GV
1627              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1628                 return NULL;
1629             return varname(gv, funny, 0, NULL, 0, subscript_type);
1630         }
1631         return
1632             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1633     }
1634 }
1635
1636 static SV *
1637 S_op_varname(pTHX_ const OP *o)
1638 {
1639     return S_op_varname_subscript(aTHX_ o, 1);
1640 }
1641
1642 static void
1643 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1644 { /* or not so pretty :-) */
1645     if (o->op_type == OP_CONST) {
1646         *retsv = cSVOPo_sv;
1647         if (SvPOK(*retsv)) {
1648             SV *sv = *retsv;
1649             *retsv = sv_newmortal();
1650             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1651                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1652         }
1653         else if (!SvOK(*retsv))
1654             *retpv = "undef";
1655     }
1656     else *retpv = "...";
1657 }
1658
1659 static void
1660 S_scalar_slice_warning(pTHX_ const OP *o)
1661 {
1662     OP *kid;
1663     const char lbrack =
1664         o->op_type == OP_HSLICE ? '{' : '[';
1665     const char rbrack =
1666         o->op_type == OP_HSLICE ? '}' : ']';
1667     SV *name;
1668     SV *keysv = NULL; /* just to silence compiler warnings */
1669     const char *key = NULL;
1670
1671     if (!(o->op_private & OPpSLICEWARNING))
1672         return;
1673     if (PL_parser && PL_parser->error_count)
1674         /* This warning can be nonsensical when there is a syntax error. */
1675         return;
1676
1677     kid = cLISTOPo->op_first;
1678     kid = OpSIBLING(kid); /* get past pushmark */
1679     /* weed out false positives: any ops that can return lists */
1680     switch (kid->op_type) {
1681     case OP_BACKTICK:
1682     case OP_GLOB:
1683     case OP_READLINE:
1684     case OP_MATCH:
1685     case OP_RV2AV:
1686     case OP_EACH:
1687     case OP_VALUES:
1688     case OP_KEYS:
1689     case OP_SPLIT:
1690     case OP_LIST:
1691     case OP_SORT:
1692     case OP_REVERSE:
1693     case OP_ENTERSUB:
1694     case OP_CALLER:
1695     case OP_LSTAT:
1696     case OP_STAT:
1697     case OP_READDIR:
1698     case OP_SYSTEM:
1699     case OP_TMS:
1700     case OP_LOCALTIME:
1701     case OP_GMTIME:
1702     case OP_ENTEREVAL:
1703         return;
1704     }
1705
1706     /* Don't warn if we have a nulled list either. */
1707     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1708         return;
1709
1710     assert(OpSIBLING(kid));
1711     name = S_op_varname(aTHX_ OpSIBLING(kid));
1712     if (!name) /* XS module fiddling with the op tree */
1713         return;
1714     S_op_pretty(aTHX_ kid, &keysv, &key);
1715     assert(SvPOK(name));
1716     sv_chop(name,SvPVX(name)+1);
1717     if (key)
1718        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1719         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1720                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1721                    "%c%s%c",
1722                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1723                     lbrack, key, rbrack);
1724     else
1725        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1726         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1727                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1728                     SVf"%c%"SVf"%c",
1729                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1730                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1731 }
1732
1733 OP *
1734 Perl_scalar(pTHX_ OP *o)
1735 {
1736     OP *kid;
1737
1738     /* assumes no premature commitment */
1739     if (!o || (PL_parser && PL_parser->error_count)
1740          || (o->op_flags & OPf_WANT)
1741          || o->op_type == OP_RETURN)
1742     {
1743         return o;
1744     }
1745
1746     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1747
1748     switch (o->op_type) {
1749     case OP_REPEAT:
1750         scalar(cBINOPo->op_first);
1751         if (o->op_private & OPpREPEAT_DOLIST) {
1752             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1753             assert(kid->op_type == OP_PUSHMARK);
1754             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1755                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1756                 o->op_private &=~ OPpREPEAT_DOLIST;
1757             }
1758         }
1759         break;
1760     case OP_OR:
1761     case OP_AND:
1762     case OP_COND_EXPR:
1763         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1764             scalar(kid);
1765         break;
1766         /* FALLTHROUGH */
1767     case OP_SPLIT:
1768     case OP_MATCH:
1769     case OP_QR:
1770     case OP_SUBST:
1771     case OP_NULL:
1772     default:
1773         if (o->op_flags & OPf_KIDS) {
1774             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1775                 scalar(kid);
1776         }
1777         break;
1778     case OP_LEAVE:
1779     case OP_LEAVETRY:
1780         kid = cLISTOPo->op_first;
1781         scalar(kid);
1782         kid = OpSIBLING(kid);
1783     do_kids:
1784         while (kid) {
1785             OP *sib = OpSIBLING(kid);
1786             if (sib && kid->op_type != OP_LEAVEWHEN
1787              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1788                 || (  sib->op_targ != OP_NEXTSTATE
1789                    && sib->op_targ != OP_DBSTATE  )))
1790                 scalarvoid(kid);
1791             else
1792                 scalar(kid);
1793             kid = sib;
1794         }
1795         PL_curcop = &PL_compiling;
1796         break;
1797     case OP_SCOPE:
1798     case OP_LINESEQ:
1799     case OP_LIST:
1800         kid = cLISTOPo->op_first;
1801         goto do_kids;
1802     case OP_SORT:
1803         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1804         break;
1805     case OP_KVHSLICE:
1806     case OP_KVASLICE:
1807     {
1808         /* Warn about scalar context */
1809         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1810         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1811         SV *name;
1812         SV *keysv;
1813         const char *key = NULL;
1814
1815         /* This warning can be nonsensical when there is a syntax error. */
1816         if (PL_parser && PL_parser->error_count)
1817             break;
1818
1819         if (!ckWARN(WARN_SYNTAX)) break;
1820
1821         kid = cLISTOPo->op_first;
1822         kid = OpSIBLING(kid); /* get past pushmark */
1823         assert(OpSIBLING(kid));
1824         name = S_op_varname(aTHX_ OpSIBLING(kid));
1825         if (!name) /* XS module fiddling with the op tree */
1826             break;
1827         S_op_pretty(aTHX_ kid, &keysv, &key);
1828         assert(SvPOK(name));
1829         sv_chop(name,SvPVX(name)+1);
1830         if (key)
1831   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1832             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1833                        "%%%"SVf"%c%s%c in scalar context better written "
1834                        "as $%"SVf"%c%s%c",
1835                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1836                         lbrack, key, rbrack);
1837         else
1838   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1839             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1840                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1841                        "written as $%"SVf"%c%"SVf"%c",
1842                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1843                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1844     }
1845     }
1846     return o;
1847 }
1848
1849 OP *
1850 Perl_scalarvoid(pTHX_ OP *arg)
1851 {
1852     dVAR;
1853     OP *kid;
1854     SV* sv;
1855     U8 want;
1856     SSize_t defer_stack_alloc = 0;
1857     SSize_t defer_ix = -1;
1858     OP **defer_stack = NULL;
1859     OP *o = arg;
1860
1861     PERL_ARGS_ASSERT_SCALARVOID;
1862
1863     do {
1864         SV *useless_sv = NULL;
1865         const char* useless = NULL;
1866
1867         if (o->op_type == OP_NEXTSTATE
1868             || o->op_type == OP_DBSTATE
1869             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1870                                           || o->op_targ == OP_DBSTATE)))
1871             PL_curcop = (COP*)o;                /* for warning below */
1872
1873         /* assumes no premature commitment */
1874         want = o->op_flags & OPf_WANT;
1875         if ((want && want != OPf_WANT_SCALAR)
1876             || (PL_parser && PL_parser->error_count)
1877             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1878         {
1879             continue;
1880         }
1881
1882         if ((o->op_private & OPpTARGET_MY)
1883             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1884         {
1885             /* newASSIGNOP has already applied scalar context, which we
1886                leave, as if this op is inside SASSIGN.  */
1887             continue;
1888         }
1889
1890         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1891
1892         switch (o->op_type) {
1893         default:
1894             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1895                 break;
1896             /* FALLTHROUGH */
1897         case OP_REPEAT:
1898             if (o->op_flags & OPf_STACKED)
1899                 break;
1900             if (o->op_type == OP_REPEAT)
1901                 scalar(cBINOPo->op_first);
1902             goto func_ops;
1903         case OP_SUBSTR:
1904             if (o->op_private == 4)
1905                 break;
1906             /* FALLTHROUGH */
1907         case OP_WANTARRAY:
1908         case OP_GV:
1909         case OP_SMARTMATCH:
1910         case OP_AV2ARYLEN:
1911         case OP_REF:
1912         case OP_REFGEN:
1913         case OP_SREFGEN:
1914         case OP_DEFINED:
1915         case OP_HEX:
1916         case OP_OCT:
1917         case OP_LENGTH:
1918         case OP_VEC:
1919         case OP_INDEX:
1920         case OP_RINDEX:
1921         case OP_SPRINTF:
1922         case OP_KVASLICE:
1923         case OP_KVHSLICE:
1924         case OP_UNPACK:
1925         case OP_PACK:
1926         case OP_JOIN:
1927         case OP_LSLICE:
1928         case OP_ANONLIST:
1929         case OP_ANONHASH:
1930         case OP_SORT:
1931         case OP_REVERSE:
1932         case OP_RANGE:
1933         case OP_FLIP:
1934         case OP_FLOP:
1935         case OP_CALLER:
1936         case OP_FILENO:
1937         case OP_EOF:
1938         case OP_TELL:
1939         case OP_GETSOCKNAME:
1940         case OP_GETPEERNAME:
1941         case OP_READLINK:
1942         case OP_TELLDIR:
1943         case OP_GETPPID:
1944         case OP_GETPGRP:
1945         case OP_GETPRIORITY:
1946         case OP_TIME:
1947         case OP_TMS:
1948         case OP_LOCALTIME:
1949         case OP_GMTIME:
1950         case OP_GHBYNAME:
1951         case OP_GHBYADDR:
1952         case OP_GHOSTENT:
1953         case OP_GNBYNAME:
1954         case OP_GNBYADDR:
1955         case OP_GNETENT:
1956         case OP_GPBYNAME:
1957         case OP_GPBYNUMBER:
1958         case OP_GPROTOENT:
1959         case OP_GSBYNAME:
1960         case OP_GSBYPORT:
1961         case OP_GSERVENT:
1962         case OP_GPWNAM:
1963         case OP_GPWUID:
1964         case OP_GGRNAM:
1965         case OP_GGRGID:
1966         case OP_GETLOGIN:
1967         case OP_PROTOTYPE:
1968         case OP_RUNCV:
1969         func_ops:
1970             useless = OP_DESC(o);
1971             break;
1972
1973         case OP_GVSV:
1974         case OP_PADSV:
1975         case OP_PADAV:
1976         case OP_PADHV:
1977         case OP_PADANY:
1978         case OP_AELEM:
1979         case OP_AELEMFAST:
1980         case OP_AELEMFAST_LEX:
1981         case OP_ASLICE:
1982         case OP_HELEM:
1983         case OP_HSLICE:
1984             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1985                 /* Otherwise it's "Useless use of grep iterator" */
1986                 useless = OP_DESC(o);
1987             break;
1988
1989         case OP_SPLIT:
1990             kid = cLISTOPo->op_first;
1991             if (kid && kid->op_type == OP_PUSHRE
1992                 && !kid->op_targ
1993                 && !(o->op_flags & OPf_STACKED)
1994 #ifdef USE_ITHREADS
1995                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1996 #else
1997                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1998 #endif
1999                 )
2000                 useless = OP_DESC(o);
2001             break;
2002
2003         case OP_NOT:
2004             kid = cUNOPo->op_first;
2005             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2006                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2007                 goto func_ops;
2008             }
2009             useless = "negative pattern binding (!~)";
2010             break;
2011
2012         case OP_SUBST:
2013             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2014                 useless = "non-destructive substitution (s///r)";
2015             break;
2016
2017         case OP_TRANSR:
2018             useless = "non-destructive transliteration (tr///r)";
2019             break;
2020
2021         case OP_RV2GV:
2022         case OP_RV2SV:
2023         case OP_RV2AV:
2024         case OP_RV2HV:
2025             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2026                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2027                 useless = "a variable";
2028             break;
2029
2030         case OP_CONST:
2031             sv = cSVOPo_sv;
2032             if (cSVOPo->op_private & OPpCONST_STRICT)
2033                 no_bareword_allowed(o);
2034             else {
2035                 if (ckWARN(WARN_VOID)) {
2036                     NV nv;
2037                     /* don't warn on optimised away booleans, eg
2038                      * use constant Foo, 5; Foo || print; */
2039                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2040                         useless = NULL;
2041                     /* the constants 0 and 1 are permitted as they are
2042                        conventionally used as dummies in constructs like
2043                        1 while some_condition_with_side_effects;  */
2044                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2045                         useless = NULL;
2046                     else if (SvPOK(sv)) {
2047                         SV * const dsv = newSVpvs("");
2048                         useless_sv
2049                             = Perl_newSVpvf(aTHX_
2050                                             "a constant (%s)",
2051                                             pv_pretty(dsv, SvPVX_const(sv),
2052                                                       SvCUR(sv), 32, NULL, NULL,
2053                                                       PERL_PV_PRETTY_DUMP
2054                                                       | PERL_PV_ESCAPE_NOCLEAR
2055                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2056                         SvREFCNT_dec_NN(dsv);
2057                     }
2058                     else if (SvOK(sv)) {
2059                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2060                     }
2061                     else
2062                         useless = "a constant (undef)";
2063                 }
2064             }
2065             op_null(o);         /* don't execute or even remember it */
2066             break;
2067
2068         case OP_POSTINC:
2069             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2070             break;
2071
2072         case OP_POSTDEC:
2073             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2074             break;
2075
2076         case OP_I_POSTINC:
2077             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2078             break;
2079
2080         case OP_I_POSTDEC:
2081             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2082             break;
2083
2084         case OP_SASSIGN: {
2085             OP *rv2gv;
2086             UNOP *refgen, *rv2cv;
2087             LISTOP *exlist;
2088
2089             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2090                 break;
2091
2092             rv2gv = ((BINOP *)o)->op_last;
2093             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2094                 break;
2095
2096             refgen = (UNOP *)((BINOP *)o)->op_first;
2097
2098             if (!refgen || (refgen->op_type != OP_REFGEN
2099                             && refgen->op_type != OP_SREFGEN))
2100                 break;
2101
2102             exlist = (LISTOP *)refgen->op_first;
2103             if (!exlist || exlist->op_type != OP_NULL
2104                 || exlist->op_targ != OP_LIST)
2105                 break;
2106
2107             if (exlist->op_first->op_type != OP_PUSHMARK
2108                 && exlist->op_first != exlist->op_last)
2109                 break;
2110
2111             rv2cv = (UNOP*)exlist->op_last;
2112
2113             if (rv2cv->op_type != OP_RV2CV)
2114                 break;
2115
2116             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2117             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2118             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2119
2120             o->op_private |= OPpASSIGN_CV_TO_GV;
2121             rv2gv->op_private |= OPpDONT_INIT_GV;
2122             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2123
2124             break;
2125         }
2126
2127         case OP_AASSIGN: {
2128             inplace_aassign(o);
2129             break;
2130         }
2131
2132         case OP_OR:
2133         case OP_AND:
2134             kid = cLOGOPo->op_first;
2135             if (kid->op_type == OP_NOT
2136                 && (kid->op_flags & OPf_KIDS)) {
2137                 if (o->op_type == OP_AND) {
2138                     OpTYPE_set(o, OP_OR);
2139                 } else {
2140                     OpTYPE_set(o, OP_AND);
2141                 }
2142                 op_null(kid);
2143             }
2144             /* FALLTHROUGH */
2145
2146         case OP_DOR:
2147         case OP_COND_EXPR:
2148         case OP_ENTERGIVEN:
2149         case OP_ENTERWHEN:
2150             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2151                 if (!(kid->op_flags & OPf_KIDS))
2152                     scalarvoid(kid);
2153                 else
2154                     DEFER_OP(kid);
2155         break;
2156
2157         case OP_NULL:
2158             if (o->op_flags & OPf_STACKED)
2159                 break;
2160             /* FALLTHROUGH */
2161         case OP_NEXTSTATE:
2162         case OP_DBSTATE:
2163         case OP_ENTERTRY:
2164         case OP_ENTER:
2165             if (!(o->op_flags & OPf_KIDS))
2166                 break;
2167             /* FALLTHROUGH */
2168         case OP_SCOPE:
2169         case OP_LEAVE:
2170         case OP_LEAVETRY:
2171         case OP_LEAVELOOP:
2172         case OP_LINESEQ:
2173         case OP_LEAVEGIVEN:
2174         case OP_LEAVEWHEN:
2175         kids:
2176             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177                 if (!(kid->op_flags & OPf_KIDS))
2178                     scalarvoid(kid);
2179                 else
2180                     DEFER_OP(kid);
2181             break;
2182         case OP_LIST:
2183             /* If the first kid after pushmark is something that the padrange
2184                optimisation would reject, then null the list and the pushmark.
2185             */
2186             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2187                 && (  !(kid = OpSIBLING(kid))
2188                       || (  kid->op_type != OP_PADSV
2189                             && kid->op_type != OP_PADAV
2190                             && kid->op_type != OP_PADHV)
2191                       || kid->op_private & ~OPpLVAL_INTRO
2192                       || !(kid = OpSIBLING(kid))
2193                       || (  kid->op_type != OP_PADSV
2194                             && kid->op_type != OP_PADAV
2195                             && kid->op_type != OP_PADHV)
2196                       || kid->op_private & ~OPpLVAL_INTRO)
2197             ) {
2198                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2199                 op_null(o); /* NULL the list */
2200             }
2201             goto kids;
2202         case OP_ENTEREVAL:
2203             scalarkids(o);
2204             break;
2205         case OP_SCALAR:
2206             scalar(o);
2207             break;
2208         }
2209
2210         if (useless_sv) {
2211             /* mortalise it, in case warnings are fatal.  */
2212             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2213                            "Useless use of %"SVf" in void context",
2214                            SVfARG(sv_2mortal(useless_sv)));
2215         }
2216         else if (useless) {
2217             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218                            "Useless use of %s in void context",
2219                            useless);
2220         }
2221     } while ( (o = POP_DEFERRED_OP()) );
2222
2223     Safefree(defer_stack);
2224
2225     return arg;
2226 }
2227
2228 static OP *
2229 S_listkids(pTHX_ OP *o)
2230 {
2231     if (o && o->op_flags & OPf_KIDS) {
2232         OP *kid;
2233         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2234             list(kid);
2235     }
2236     return o;
2237 }
2238
2239 OP *
2240 Perl_list(pTHX_ OP *o)
2241 {
2242     OP *kid;
2243
2244     /* assumes no premature commitment */
2245     if (!o || (o->op_flags & OPf_WANT)
2246          || (PL_parser && PL_parser->error_count)
2247          || o->op_type == OP_RETURN)
2248     {
2249         return o;
2250     }
2251
2252     if ((o->op_private & OPpTARGET_MY)
2253         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2254     {
2255         return o;                               /* As if inside SASSIGN */
2256     }
2257
2258     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2259
2260     switch (o->op_type) {
2261     case OP_FLOP:
2262         list(cBINOPo->op_first);
2263         break;
2264     case OP_REPEAT:
2265         if (o->op_private & OPpREPEAT_DOLIST
2266          && !(o->op_flags & OPf_STACKED))
2267         {
2268             list(cBINOPo->op_first);
2269             kid = cBINOPo->op_last;
2270             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2271              && SvIVX(kSVOP_sv) == 1)
2272             {
2273                 op_null(o); /* repeat */
2274                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2275                 /* const (rhs): */
2276                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2277             }
2278         }
2279         break;
2280     case OP_OR:
2281     case OP_AND:
2282     case OP_COND_EXPR:
2283         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2284             list(kid);
2285         break;
2286     default:
2287     case OP_MATCH:
2288     case OP_QR:
2289     case OP_SUBST:
2290     case OP_NULL:
2291         if (!(o->op_flags & OPf_KIDS))
2292             break;
2293         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2294             list(cBINOPo->op_first);
2295             return gen_constant_list(o);
2296         }
2297         listkids(o);
2298         break;
2299     case OP_LIST:
2300         listkids(o);
2301         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2302             op_null(cUNOPo->op_first); /* NULL the pushmark */
2303             op_null(o); /* NULL the list */
2304         }
2305         break;
2306     case OP_LEAVE:
2307     case OP_LEAVETRY:
2308         kid = cLISTOPo->op_first;
2309         list(kid);
2310         kid = OpSIBLING(kid);
2311     do_kids:
2312         while (kid) {
2313             OP *sib = OpSIBLING(kid);
2314             if (sib && kid->op_type != OP_LEAVEWHEN)
2315                 scalarvoid(kid);
2316             else
2317                 list(kid);
2318             kid = sib;
2319         }
2320         PL_curcop = &PL_compiling;
2321         break;
2322     case OP_SCOPE:
2323     case OP_LINESEQ:
2324         kid = cLISTOPo->op_first;
2325         goto do_kids;
2326     }
2327     return o;
2328 }
2329
2330 static OP *
2331 S_scalarseq(pTHX_ OP *o)
2332 {
2333     if (o) {
2334         const OPCODE type = o->op_type;
2335
2336         if (type == OP_LINESEQ || type == OP_SCOPE ||
2337             type == OP_LEAVE || type == OP_LEAVETRY)
2338         {
2339             OP *kid, *sib;
2340             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2341                 if ((sib = OpSIBLING(kid))
2342                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2343                     || (  sib->op_targ != OP_NEXTSTATE
2344                        && sib->op_targ != OP_DBSTATE  )))
2345                 {
2346                     scalarvoid(kid);
2347                 }
2348             }
2349             PL_curcop = &PL_compiling;
2350         }
2351         o->op_flags &= ~OPf_PARENS;
2352         if (PL_hints & HINT_BLOCK_SCOPE)
2353             o->op_flags |= OPf_PARENS;
2354     }
2355     else
2356         o = newOP(OP_STUB, 0);
2357     return o;
2358 }
2359
2360 STATIC OP *
2361 S_modkids(pTHX_ OP *o, I32 type)
2362 {
2363     if (o && o->op_flags & OPf_KIDS) {
2364         OP *kid;
2365         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2366             op_lvalue(kid, type);
2367     }
2368     return o;
2369 }
2370
2371
2372 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2373  * const fields. Also, convert CONST keys to HEK-in-SVs.
2374  * rop is the op that retrieves the hash;
2375  * key_op is the first key
2376  */
2377
2378 STATIC void
2379 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2380 {
2381     PADNAME *lexname;
2382     GV **fields;
2383     bool check_fields;
2384
2385     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2386     if (rop) {
2387         if (rop->op_first->op_type == OP_PADSV)
2388             /* @$hash{qw(keys here)} */
2389             rop = (UNOP*)rop->op_first;
2390         else {
2391             /* @{$hash}{qw(keys here)} */
2392             if (rop->op_first->op_type == OP_SCOPE
2393                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2394                 {
2395                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2396                 }
2397             else
2398                 rop = NULL;
2399         }
2400     }
2401
2402     lexname = NULL; /* just to silence compiler warnings */
2403     fields  = NULL; /* just to silence compiler warnings */
2404
2405     check_fields =
2406             rop
2407          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2408              SvPAD_TYPED(lexname))
2409          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2410          && isGV(*fields) && GvHV(*fields);
2411
2412     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2413         SV **svp, *sv;
2414         if (key_op->op_type != OP_CONST)
2415             continue;
2416         svp = cSVOPx_svp(key_op);
2417
2418         /* make sure it's not a bareword under strict subs */
2419         if (key_op->op_private & OPpCONST_BARE &&
2420             key_op->op_private & OPpCONST_STRICT)
2421         {
2422             no_bareword_allowed((OP*)key_op);
2423         }
2424
2425         /* Make the CONST have a shared SV */
2426         if (   !SvIsCOW_shared_hash(sv = *svp)
2427             && SvTYPE(sv) < SVt_PVMG
2428             && SvOK(sv)
2429             && !SvROK(sv))
2430         {
2431             SSize_t keylen;
2432             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2433             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2434             SvREFCNT_dec_NN(sv);
2435             *svp = nsv;
2436         }
2437
2438         if (   check_fields
2439             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2440         {
2441             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2442                         "in variable %"PNf" of type %"HEKf,
2443                         SVfARG(*svp), PNfARG(lexname),
2444                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2445         }
2446     }
2447 }
2448
2449
2450 /*
2451 =for apidoc finalize_optree
2452
2453 This function finalizes the optree.  Should be called directly after
2454 the complete optree is built.  It does some additional
2455 checking which can't be done in the normal C<ck_>xxx functions and makes
2456 the tree thread-safe.
2457
2458 =cut
2459 */
2460 void
2461 Perl_finalize_optree(pTHX_ OP* o)
2462 {
2463     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2464
2465     ENTER;
2466     SAVEVPTR(PL_curcop);
2467
2468     finalize_op(o);
2469
2470     LEAVE;
2471 }
2472
2473 #ifdef USE_ITHREADS
2474 /* Relocate sv to the pad for thread safety.
2475  * Despite being a "constant", the SV is written to,
2476  * for reference counts, sv_upgrade() etc. */
2477 PERL_STATIC_INLINE void
2478 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2479 {
2480     PADOFFSET ix;
2481     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2482     if (!*svp) return;
2483     ix = pad_alloc(OP_CONST, SVf_READONLY);
2484     SvREFCNT_dec(PAD_SVl(ix));
2485     PAD_SETSV(ix, *svp);
2486     /* XXX I don't know how this isn't readonly already. */
2487     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2488     *svp = NULL;
2489     *targp = ix;
2490 }
2491 #endif
2492
2493
2494 STATIC void
2495 S_finalize_op(pTHX_ OP* o)
2496 {
2497     PERL_ARGS_ASSERT_FINALIZE_OP;
2498
2499
2500     switch (o->op_type) {
2501     case OP_NEXTSTATE:
2502     case OP_DBSTATE:
2503         PL_curcop = ((COP*)o);          /* for warnings */
2504         break;
2505     case OP_EXEC:
2506         if (OpHAS_SIBLING(o)) {
2507             OP *sib = OpSIBLING(o);
2508             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2509                 && ckWARN(WARN_EXEC)
2510                 && OpHAS_SIBLING(sib))
2511             {
2512                     const OPCODE type = OpSIBLING(sib)->op_type;
2513                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2514                         const line_t oldline = CopLINE(PL_curcop);
2515                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2516                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2517                             "Statement unlikely to be reached");
2518                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2519                             "\t(Maybe you meant system() when you said exec()?)\n");
2520                         CopLINE_set(PL_curcop, oldline);
2521                     }
2522             }
2523         }
2524         break;
2525
2526     case OP_GV:
2527         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2528             GV * const gv = cGVOPo_gv;
2529             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2530                 /* XXX could check prototype here instead of just carping */
2531                 SV * const sv = sv_newmortal();
2532                 gv_efullname3(sv, gv, NULL);
2533                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2534                     "%"SVf"() called too early to check prototype",
2535                     SVfARG(sv));
2536             }
2537         }
2538         break;
2539
2540     case OP_CONST:
2541         if (cSVOPo->op_private & OPpCONST_STRICT)
2542             no_bareword_allowed(o);
2543         /* FALLTHROUGH */
2544 #ifdef USE_ITHREADS
2545     case OP_HINTSEVAL:
2546         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2547 #endif
2548         break;
2549
2550 #ifdef USE_ITHREADS
2551     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2552     case OP_METHOD_NAMED:
2553     case OP_METHOD_SUPER:
2554     case OP_METHOD_REDIR:
2555     case OP_METHOD_REDIR_SUPER:
2556         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2557         break;
2558 #endif
2559
2560     case OP_HELEM: {
2561         UNOP *rop;
2562         SVOP *key_op;
2563         OP *kid;
2564
2565         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2566             break;
2567
2568         rop = (UNOP*)((BINOP*)o)->op_first;
2569
2570         goto check_keys;
2571
2572     case OP_HSLICE:
2573         S_scalar_slice_warning(aTHX_ o);
2574         /* FALLTHROUGH */
2575
2576     case OP_KVHSLICE:
2577         kid = OpSIBLING(cLISTOPo->op_first);
2578         if (/* I bet there's always a pushmark... */
2579             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2580             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2581         {
2582             break;
2583         }
2584
2585         key_op = (SVOP*)(kid->op_type == OP_CONST
2586                                 ? kid
2587                                 : OpSIBLING(kLISTOP->op_first));
2588
2589         rop = (UNOP*)((LISTOP*)o)->op_last;
2590
2591       check_keys:       
2592         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2593             rop = NULL;
2594         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2595         break;
2596     }
2597     case OP_ASLICE:
2598         S_scalar_slice_warning(aTHX_ o);
2599         break;
2600
2601     case OP_SUBST: {
2602         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2603             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2604         break;
2605     }
2606     default:
2607         break;
2608     }
2609
2610     if (o->op_flags & OPf_KIDS) {
2611         OP *kid;
2612
2613 #ifdef DEBUGGING
2614         /* check that op_last points to the last sibling, and that
2615          * the last op_sibling/op_sibparent field points back to the
2616          * parent, and that the only ops with KIDS are those which are
2617          * entitled to them */
2618         U32 type = o->op_type;
2619         U32 family;
2620         bool has_last;
2621
2622         if (type == OP_NULL) {
2623             type = o->op_targ;
2624             /* ck_glob creates a null UNOP with ex-type GLOB
2625              * (which is a list op. So pretend it wasn't a listop */
2626             if (type == OP_GLOB)
2627                 type = OP_NULL;
2628         }
2629         family = PL_opargs[type] & OA_CLASS_MASK;
2630
2631         has_last = (   family == OA_BINOP
2632                     || family == OA_LISTOP
2633                     || family == OA_PMOP
2634                     || family == OA_LOOP
2635                    );
2636         assert(  has_last /* has op_first and op_last, or ...
2637               ... has (or may have) op_first: */
2638               || family == OA_UNOP
2639               || family == OA_UNOP_AUX
2640               || family == OA_LOGOP
2641               || family == OA_BASEOP_OR_UNOP
2642               || family == OA_FILESTATOP
2643               || family == OA_LOOPEXOP
2644               || family == OA_METHOP
2645               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2646               || type == OP_SASSIGN
2647               || type == OP_CUSTOM
2648               || type == OP_NULL /* new_logop does this */
2649               );
2650
2651         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2652 #  ifdef PERL_OP_PARENT
2653             if (!OpHAS_SIBLING(kid)) {
2654                 if (has_last)
2655                     assert(kid == cLISTOPo->op_last);
2656                 assert(kid->op_sibparent == o);
2657             }
2658 #  else
2659             if (has_last && !OpHAS_SIBLING(kid))
2660                 assert(kid == cLISTOPo->op_last);
2661 #  endif
2662         }
2663 #endif
2664
2665         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2666             finalize_op(kid);
2667     }
2668 }
2669
2670 /*
2671 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2672
2673 Propagate lvalue ("modifiable") context to an op and its children.
2674 C<type> represents the context type, roughly based on the type of op that
2675 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2676 because it has no op type of its own (it is signalled by a flag on
2677 the lvalue op).
2678
2679 This function detects things that can't be modified, such as C<$x+1>, and
2680 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2681 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2682
2683 It also flags things that need to behave specially in an lvalue context,
2684 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2685
2686 =cut
2687 */
2688
2689 static void
2690 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2691 {
2692     CV *cv = PL_compcv;
2693     PadnameLVALUE_on(pn);
2694     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2695         cv = CvOUTSIDE(cv);
2696         /* RT #127786: cv can be NULL due to an eval within the DB package
2697          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2698          * unless they contain an eval, but calling eval within DB
2699          * pretends the eval was done in the caller's scope.
2700          */
2701         if (!cv)
2702             break;
2703         assert(CvPADLIST(cv));
2704         pn =
2705            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2706         assert(PadnameLEN(pn));
2707         PadnameLVALUE_on(pn);
2708     }
2709 }
2710
2711 static bool
2712 S_vivifies(const OPCODE type)
2713 {
2714     switch(type) {
2715     case OP_RV2AV:     case   OP_ASLICE:
2716     case OP_RV2HV:     case OP_KVASLICE:
2717     case OP_RV2SV:     case   OP_HSLICE:
2718     case OP_AELEMFAST: case OP_KVHSLICE:
2719     case OP_HELEM:
2720     case OP_AELEM:
2721         return 1;
2722     }
2723     return 0;
2724 }
2725
2726 static void
2727 S_lvref(pTHX_ OP *o, I32 type)
2728 {
2729     dVAR;
2730     OP *kid;
2731     switch (o->op_type) {
2732     case OP_COND_EXPR:
2733         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2734              kid = OpSIBLING(kid))
2735             S_lvref(aTHX_ kid, type);
2736         /* FALLTHROUGH */
2737     case OP_PUSHMARK:
2738         return;
2739     case OP_RV2AV:
2740         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2741         o->op_flags |= OPf_STACKED;
2742         if (o->op_flags & OPf_PARENS) {
2743             if (o->op_private & OPpLVAL_INTRO) {
2744                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2745                       "localized parenthesized array in list assignment"));
2746                 return;
2747             }
2748           slurpy:
2749             OpTYPE_set(o, OP_LVAVREF);
2750             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2751             o->op_flags |= OPf_MOD|OPf_REF;
2752             return;
2753         }
2754         o->op_private |= OPpLVREF_AV;
2755         goto checkgv;
2756     case OP_RV2CV:
2757         kid = cUNOPo->op_first;
2758         if (kid->op_type == OP_NULL)
2759             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2760                 ->op_first;
2761         o->op_private = OPpLVREF_CV;
2762         if (kid->op_type == OP_GV)
2763             o->op_flags |= OPf_STACKED;
2764         else if (kid->op_type == OP_PADCV) {
2765             o->op_targ = kid->op_targ;
2766             kid->op_targ = 0;
2767             op_free(cUNOPo->op_first);
2768             cUNOPo->op_first = NULL;
2769             o->op_flags &=~ OPf_KIDS;
2770         }
2771         else goto badref;
2772         break;
2773     case OP_RV2HV:
2774         if (o->op_flags & OPf_PARENS) {
2775           parenhash:
2776             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2777                                  "parenthesized hash in list assignment"));
2778                 return;
2779         }
2780         o->op_private |= OPpLVREF_HV;
2781         /* FALLTHROUGH */
2782     case OP_RV2SV:
2783       checkgv:
2784         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2785         o->op_flags |= OPf_STACKED;
2786         break;
2787     case OP_PADHV:
2788         if (o->op_flags & OPf_PARENS) goto parenhash;
2789         o->op_private |= OPpLVREF_HV;
2790         /* FALLTHROUGH */
2791     case OP_PADSV:
2792         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2793         break;
2794     case OP_PADAV:
2795         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2796         if (o->op_flags & OPf_PARENS) goto slurpy;
2797         o->op_private |= OPpLVREF_AV;
2798         break;
2799     case OP_AELEM:
2800     case OP_HELEM:
2801         o->op_private |= OPpLVREF_ELEM;
2802         o->op_flags   |= OPf_STACKED;
2803         break;
2804     case OP_ASLICE:
2805     case OP_HSLICE:
2806         OpTYPE_set(o, OP_LVREFSLICE);
2807         o->op_private &= OPpLVAL_INTRO;
2808         return;
2809     case OP_NULL:
2810         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2811             goto badref;
2812         else if (!(o->op_flags & OPf_KIDS))
2813             return;
2814         if (o->op_targ != OP_LIST) {
2815             S_lvref(aTHX_ cBINOPo->op_first, type);
2816             return;
2817         }
2818         /* FALLTHROUGH */
2819     case OP_LIST:
2820         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2821             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2822             S_lvref(aTHX_ kid, type);
2823         }
2824         return;
2825     case OP_STUB:
2826         if (o->op_flags & OPf_PARENS)
2827             return;
2828         /* FALLTHROUGH */
2829     default:
2830       badref:
2831         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2832         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2833                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2834                       ? "do block"
2835                       : OP_DESC(o),
2836                      PL_op_desc[type]));
2837     }
2838     OpTYPE_set(o, OP_LVREF);
2839     o->op_private &=
2840         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2841     if (type == OP_ENTERLOOP)
2842         o->op_private |= OPpLVREF_ITER;
2843 }
2844
2845 PERL_STATIC_INLINE bool
2846 S_potential_mod_type(I32 type)
2847 {
2848     /* Types that only potentially result in modification.  */
2849     return type == OP_GREPSTART || type == OP_ENTERSUB
2850         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2851 }
2852
2853 OP *
2854 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2855 {
2856     dVAR;
2857     OP *kid;
2858     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2859     int localize = -1;
2860
2861     if (!o || (PL_parser && PL_parser->error_count))
2862         return o;
2863
2864     if ((o->op_private & OPpTARGET_MY)
2865         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2866     {
2867         return o;
2868     }
2869
2870     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2871
2872     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2873
2874     switch (o->op_type) {
2875     case OP_UNDEF:
2876         PL_modcount++;
2877         return o;
2878     case OP_STUB:
2879         if ((o->op_flags & OPf_PARENS))
2880             break;
2881         goto nomod;
2882     case OP_ENTERSUB:
2883         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2884             !(o->op_flags & OPf_STACKED)) {
2885             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2886             assert(cUNOPo->op_first->op_type == OP_NULL);
2887             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2888             break;
2889         }
2890         else {                          /* lvalue subroutine call */
2891             o->op_private |= OPpLVAL_INTRO;
2892             PL_modcount = RETURN_UNLIMITED_NUMBER;
2893             if (S_potential_mod_type(type)) {
2894                 o->op_private |= OPpENTERSUB_INARGS;
2895                 break;
2896             }
2897             else {                      /* Compile-time error message: */
2898                 OP *kid = cUNOPo->op_first;
2899                 CV *cv;
2900                 GV *gv;
2901                 SV *namesv;
2902
2903                 if (kid->op_type != OP_PUSHMARK) {
2904                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2905                         Perl_croak(aTHX_
2906                                 "panic: unexpected lvalue entersub "
2907                                 "args: type/targ %ld:%"UVuf,
2908                                 (long)kid->op_type, (UV)kid->op_targ);
2909                     kid = kLISTOP->op_first;
2910                 }
2911                 while (OpHAS_SIBLING(kid))
2912                     kid = OpSIBLING(kid);
2913                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2914                     break;      /* Postpone until runtime */
2915                 }
2916
2917                 kid = kUNOP->op_first;
2918                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2919                     kid = kUNOP->op_first;
2920                 if (kid->op_type == OP_NULL)
2921                     Perl_croak(aTHX_
2922                                "Unexpected constant lvalue entersub "
2923                                "entry via type/targ %ld:%"UVuf,
2924                                (long)kid->op_type, (UV)kid->op_targ);
2925                 if (kid->op_type != OP_GV) {
2926                     break;
2927                 }
2928
2929                 gv = kGVOP_gv;
2930                 cv = isGV(gv)
2931                     ? GvCV(gv)
2932                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2933                         ? MUTABLE_CV(SvRV(gv))
2934                         : NULL;
2935                 if (!cv)
2936                     break;
2937                 if (CvLVALUE(cv))
2938                     break;
2939                 if (flags & OP_LVALUE_NO_CROAK)
2940                     return NULL;
2941
2942                 namesv = cv_name(cv, NULL, 0);
2943                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2944                                      "subroutine call of &%"SVf" in %s",
2945                                      SVfARG(namesv), PL_op_desc[type]),
2946                            SvUTF8(namesv));
2947                 return o;
2948             }
2949         }
2950         /* FALLTHROUGH */
2951     default:
2952       nomod:
2953         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2954         /* grep, foreach, subcalls, refgen */
2955         if (S_potential_mod_type(type))
2956             break;
2957         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2958                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2959                       ? "do block"
2960                       : OP_DESC(o)),
2961                      type ? PL_op_desc[type] : "local"));
2962         return o;
2963
2964     case OP_PREINC:
2965     case OP_PREDEC:
2966     case OP_POW:
2967     case OP_MULTIPLY:
2968     case OP_DIVIDE:
2969     case OP_MODULO:
2970     case OP_ADD:
2971     case OP_SUBTRACT:
2972     case OP_CONCAT:
2973     case OP_LEFT_SHIFT:
2974     case OP_RIGHT_SHIFT:
2975     case OP_BIT_AND:
2976     case OP_BIT_XOR:
2977     case OP_BIT_OR:
2978     case OP_I_MULTIPLY:
2979     case OP_I_DIVIDE:
2980     case OP_I_MODULO:
2981     case OP_I_ADD:
2982     case OP_I_SUBTRACT:
2983         if (!(o->op_flags & OPf_STACKED))
2984             goto nomod;
2985         PL_modcount++;
2986         break;
2987
2988     case OP_REPEAT:
2989         if (o->op_flags & OPf_STACKED) {
2990             PL_modcount++;
2991             break;
2992         }
2993         if (!(o->op_private & OPpREPEAT_DOLIST))
2994             goto nomod;
2995         else {
2996             const I32 mods = PL_modcount;
2997             modkids(cBINOPo->op_first, type);
2998             if (type != OP_AASSIGN)
2999                 goto nomod;
3000             kid = cBINOPo->op_last;
3001             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3002                 const IV iv = SvIV(kSVOP_sv);
3003                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3004                     PL_modcount =
3005                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3006             }
3007             else
3008                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3009         }
3010         break;
3011
3012     case OP_COND_EXPR:
3013         localize = 1;
3014         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3015             op_lvalue(kid, type);
3016         break;
3017
3018     case OP_RV2AV:
3019     case OP_RV2HV:
3020         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3021            PL_modcount = RETURN_UNLIMITED_NUMBER;
3022             return o;           /* Treat \(@foo) like ordinary list. */
3023         }
3024         /* FALLTHROUGH */
3025     case OP_RV2GV:
3026         if (scalar_mod_type(o, type))
3027             goto nomod;
3028         ref(cUNOPo->op_first, o->op_type);
3029         /* FALLTHROUGH */
3030     case OP_ASLICE:
3031     case OP_HSLICE:
3032         localize = 1;
3033         /* FALLTHROUGH */
3034     case OP_AASSIGN:
3035         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3036         if (type == OP_LEAVESUBLV && (
3037                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3038              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3039            ))
3040             o->op_private |= OPpMAYBE_LVSUB;
3041         /* FALLTHROUGH */
3042     case OP_NEXTSTATE:
3043     case OP_DBSTATE:
3044        PL_modcount = RETURN_UNLIMITED_NUMBER;
3045         break;
3046     case OP_KVHSLICE:
3047     case OP_KVASLICE:
3048     case OP_AKEYS:
3049         if (type == OP_LEAVESUBLV)
3050             o->op_private |= OPpMAYBE_LVSUB;
3051         goto nomod;
3052     case OP_AVHVSWITCH:
3053         if (type == OP_LEAVESUBLV
3054          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3055             o->op_private |= OPpMAYBE_LVSUB;
3056         goto nomod;
3057     case OP_AV2ARYLEN:
3058         PL_hints |= HINT_BLOCK_SCOPE;
3059         if (type == OP_LEAVESUBLV)
3060             o->op_private |= OPpMAYBE_LVSUB;
3061         PL_modcount++;
3062         break;
3063     case OP_RV2SV:
3064         ref(cUNOPo->op_first, o->op_type);
3065         localize = 1;
3066         /* FALLTHROUGH */
3067     case OP_GV:
3068         PL_hints |= HINT_BLOCK_SCOPE;
3069         /* FALLTHROUGH */
3070     case OP_SASSIGN:
3071     case OP_ANDASSIGN:
3072     case OP_ORASSIGN:
3073     case OP_DORASSIGN:
3074         PL_modcount++;
3075         break;
3076
3077     case OP_AELEMFAST:
3078     case OP_AELEMFAST_LEX:
3079         localize = -1;
3080         PL_modcount++;
3081         break;
3082
3083     case OP_PADAV:
3084     case OP_PADHV:
3085        PL_modcount = RETURN_UNLIMITED_NUMBER;
3086         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3087             return o;           /* Treat \(@foo) like ordinary list. */
3088         if (scalar_mod_type(o, type))
3089             goto nomod;
3090         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3091           && type == OP_LEAVESUBLV)
3092             o->op_private |= OPpMAYBE_LVSUB;
3093         /* FALLTHROUGH */
3094     case OP_PADSV:
3095         PL_modcount++;
3096         if (!type) /* local() */
3097             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3098                               PNfARG(PAD_COMPNAME(o->op_targ)));
3099         if (!(o->op_private & OPpLVAL_INTRO)
3100          || (  type != OP_SASSIGN && type != OP_AASSIGN
3101             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3102             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3103         break;
3104
3105     case OP_PUSHMARK:
3106         localize = 0;
3107         break;
3108
3109     case OP_KEYS:
3110         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3111             goto nomod;
3112         goto lvalue_func;
3113     case OP_SUBSTR:
3114         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3115             goto nomod;
3116         /* FALLTHROUGH */
3117     case OP_POS:
3118     case OP_VEC:
3119       lvalue_func:
3120         if (type == OP_LEAVESUBLV)
3121             o->op_private |= OPpMAYBE_LVSUB;
3122         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3123             /* substr and vec */
3124             /* If this op is in merely potential (non-fatal) modifiable
3125                context, then apply OP_ENTERSUB context to
3126                the kid op (to avoid croaking).  Other-
3127                wise pass this op’s own type so the correct op is mentioned
3128                in error messages.  */
3129             op_lvalue(OpSIBLING(cBINOPo->op_first),
3130                       S_potential_mod_type(type)
3131                         ? (I32)OP_ENTERSUB
3132                         : o->op_type);
3133         }
3134         break;
3135
3136     case OP_AELEM:
3137     case OP_HELEM:
3138         ref(cBINOPo->op_first, o->op_type);
3139         if (type == OP_ENTERSUB &&
3140              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3141             o->op_private |= OPpLVAL_DEFER;
3142         if (type == OP_LEAVESUBLV)
3143             o->op_private |= OPpMAYBE_LVSUB;
3144         localize = 1;
3145         PL_modcount++;
3146         break;
3147
3148     case OP_LEAVE:
3149     case OP_LEAVELOOP:
3150         o->op_private |= OPpLVALUE;
3151         /* FALLTHROUGH */
3152     case OP_SCOPE:
3153     case OP_ENTER:
3154     case OP_LINESEQ:
3155         localize = 0;
3156         if (o->op_flags & OPf_KIDS)
3157             op_lvalue(cLISTOPo->op_last, type);
3158         break;
3159
3160     case OP_NULL:
3161         localize = 0;
3162         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3163             goto nomod;
3164         else if (!(o->op_flags & OPf_KIDS))
3165             break;
3166         if (o->op_targ != OP_LIST) {
3167             op_lvalue(cBINOPo->op_first, type);
3168             break;
3169         }
3170         /* FALLTHROUGH */
3171     case OP_LIST:
3172         localize = 0;
3173         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3174             /* elements might be in void context because the list is
3175                in scalar context or because they are attribute sub calls */
3176             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3177                 op_lvalue(kid, type);
3178         break;
3179
3180     case OP_COREARGS:
3181         return o;
3182
3183     case OP_AND:
3184     case OP_OR:
3185         if (type == OP_LEAVESUBLV
3186          || !S_vivifies(cLOGOPo->op_first->op_type))
3187             op_lvalue(cLOGOPo->op_first, type);
3188         if (type == OP_LEAVESUBLV
3189          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3190             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3191         goto nomod;
3192
3193     case OP_SREFGEN:
3194         if (type == OP_NULL) { /* local */
3195           local_refgen:
3196             op_lvalue(cUNOPo->op_first, OP_NULL);
3197             return o;
3198         }
3199         if (type != OP_AASSIGN && type != OP_SASSIGN
3200          && type != OP_ENTERLOOP)
3201             goto nomod;
3202         /* Don’t bother applying lvalue context to the ex-list.  */
3203         kid = cUNOPx(cUNOPo->op_first)->op_first;
3204         assert (!OpHAS_SIBLING(kid));
3205         goto kid_2lvref;
3206     case OP_REFGEN:
3207         if (type == OP_NULL) /* local */
3208             goto local_refgen;
3209         if (type != OP_AASSIGN) goto nomod;
3210         kid = cUNOPo->op_first;
3211       kid_2lvref:
3212         {
3213             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3214             S_lvref(aTHX_ kid, type);
3215             if (!PL_parser || PL_parser->error_count == ec) {
3216                 if (!FEATURE_REFALIASING_IS_ENABLED)
3217                     Perl_croak(aTHX_
3218                        "Experimental aliasing via reference not enabled");
3219                 Perl_ck_warner_d(aTHX_
3220                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3221                                 "Aliasing via reference is experimental");
3222             }
3223         }
3224         if (o->op_type == OP_REFGEN)
3225             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3226         op_null(o);
3227         return o;
3228
3229     case OP_SPLIT:
3230         kid = cLISTOPo->op_first;
3231         if (kid && kid->op_type == OP_PUSHRE &&
3232                 (  kid->op_targ
3233                 || o->op_flags & OPf_STACKED
3234 #ifdef USE_ITHREADS
3235                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3236 #else
3237                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3238 #endif
3239         )) {
3240             /* This is actually @array = split.  */
3241             PL_modcount = RETURN_UNLIMITED_NUMBER;
3242             break;
3243         }
3244         goto nomod;
3245
3246     case OP_SCALAR:
3247         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3248         goto nomod;
3249     }
3250
3251     /* [20011101.069] File test operators interpret OPf_REF to mean that
3252        their argument is a filehandle; thus \stat(".") should not set
3253        it. AMS 20011102 */
3254     if (type == OP_REFGEN &&
3255         PL_check[o->op_type] == Perl_ck_ftst)
3256         return o;
3257
3258     if (type != OP_LEAVESUBLV)
3259         o->op_flags |= OPf_MOD;
3260
3261     if (type == OP_AASSIGN || type == OP_SASSIGN)
3262         o->op_flags |= OPf_SPECIAL|OPf_REF;
3263     else if (!type) { /* local() */
3264         switch (localize) {
3265         case 1:
3266             o->op_private |= OPpLVAL_INTRO;
3267             o->op_flags &= ~OPf_SPECIAL;
3268             PL_hints |= HINT_BLOCK_SCOPE;
3269             break;
3270         case 0:
3271             break;
3272         case -1:
3273             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3274                            "Useless localization of %s", OP_DESC(o));
3275         }
3276     }
3277     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3278              && type != OP_LEAVESUBLV)
3279         o->op_flags |= OPf_REF;
3280     return o;
3281 }
3282
3283 STATIC bool
3284 S_scalar_mod_type(const OP *o, I32 type)
3285 {
3286     switch (type) {
3287     case OP_POS:
3288     case OP_SASSIGN:
3289         if (o && o->op_type == OP_RV2GV)
3290             return FALSE;
3291         /* FALLTHROUGH */
3292     case OP_PREINC:
3293     case OP_PREDEC:
3294     case OP_POSTINC:
3295     case OP_POSTDEC:
3296     case OP_I_PREINC:
3297     case OP_I_PREDEC:
3298     case OP_I_POSTINC:
3299     case OP_I_POSTDEC:
3300     case OP_POW:
3301     case OP_MULTIPLY:
3302     case OP_DIVIDE:
3303     case OP_MODULO:
3304     case OP_REPEAT:
3305     case OP_ADD:
3306     case OP_SUBTRACT:
3307     case OP_I_MULTIPLY:
3308     case OP_I_DIVIDE:
3309     case OP_I_MODULO:
3310     case OP_I_ADD:
3311     case OP_I_SUBTRACT:
3312     case OP_LEFT_SHIFT:
3313     case OP_RIGHT_SHIFT:
3314     case OP_BIT_AND:
3315     case OP_BIT_XOR:
3316     case OP_BIT_OR:
3317     case OP_NBIT_AND:
3318     case OP_NBIT_XOR:
3319     case OP_NBIT_OR:
3320     case OP_SBIT_AND:
3321     case OP_SBIT_XOR:
3322     case OP_SBIT_OR:
3323     case OP_CONCAT:
3324     case OP_SUBST:
3325     case OP_TRANS:
3326     case OP_TRANSR:
3327     case OP_READ:
3328     case OP_SYSREAD:
3329     case OP_RECV:
3330     case OP_ANDASSIGN:
3331     case OP_ORASSIGN:
3332     case OP_DORASSIGN:
3333     case OP_VEC:
3334     case OP_SUBSTR:
3335         return TRUE;
3336     default:
3337         return FALSE;
3338     }
3339 }
3340
3341 STATIC bool
3342 S_is_handle_constructor(const OP *o, I32 numargs)
3343 {
3344     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3345
3346     switch (o->op_type) {
3347     case OP_PIPE_OP:
3348     case OP_SOCKPAIR:
3349         if (numargs == 2)
3350             return TRUE;
3351         /* FALLTHROUGH */
3352     case OP_SYSOPEN:
3353     case OP_OPEN:
3354     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3355     case OP_SOCKET:
3356     case OP_OPEN_DIR:
3357     case OP_ACCEPT:
3358         if (numargs == 1)
3359             return TRUE;
3360         /* FALLTHROUGH */
3361     default:
3362         return FALSE;
3363     }
3364 }
3365
3366 static OP *
3367 S_refkids(pTHX_ OP *o, I32 type)
3368 {
3369     if (o && o->op_flags & OPf_KIDS) {
3370         OP *kid;
3371         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3372             ref(kid, type);
3373     }
3374     return o;
3375 }
3376
3377 OP *
3378 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3379 {
3380     dVAR;
3381     OP *kid;
3382
3383     PERL_ARGS_ASSERT_DOREF;
3384
3385     if (PL_parser && PL_parser->error_count)
3386         return o;
3387
3388     switch (o->op_type) {
3389     case OP_ENTERSUB:
3390         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3391             !(o->op_flags & OPf_STACKED)) {
3392             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3393             assert(cUNOPo->op_first->op_type == OP_NULL);
3394             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3395             o->op_flags |= OPf_SPECIAL;
3396         }
3397         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3398             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3399                               : type == OP_RV2HV ? OPpDEREF_HV
3400                               : OPpDEREF_SV);
3401             o->op_flags |= OPf_MOD;
3402         }
3403
3404         break;
3405
3406     case OP_COND_EXPR:
3407         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3408             doref(kid, type, set_op_ref);
3409         break;
3410     case OP_RV2SV:
3411         if (type == OP_DEFINED)
3412             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3413         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3414         /* FALLTHROUGH */
3415     case OP_PADSV:
3416         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3417             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3418                               : type == OP_RV2HV ? OPpDEREF_HV
3419                               : OPpDEREF_SV);
3420             o->op_flags |= OPf_MOD;
3421         }
3422         break;
3423
3424     case OP_RV2AV:
3425     case OP_RV2HV:
3426         if (set_op_ref)
3427             o->op_flags |= OPf_REF;
3428         /* FALLTHROUGH */
3429     case OP_RV2GV:
3430         if (type == OP_DEFINED)
3431             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3432         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3433         break;
3434
3435     case OP_PADAV:
3436     case OP_PADHV:
3437         if (set_op_ref)
3438             o->op_flags |= OPf_REF;
3439         break;
3440
3441     case OP_SCALAR:
3442     case OP_NULL:
3443         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3444             break;
3445         doref(cBINOPo->op_first, type, set_op_ref);
3446         break;
3447     case OP_AELEM:
3448     case OP_HELEM:
3449         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3450         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3451             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3452                               : type == OP_RV2HV ? OPpDEREF_HV
3453                               : OPpDEREF_SV);
3454             o->op_flags |= OPf_MOD;
3455         }
3456         break;
3457
3458     case OP_SCOPE:
3459     case OP_LEAVE:
3460         set_op_ref = FALSE;
3461         /* FALLTHROUGH */
3462     case OP_ENTER:
3463     case OP_LIST:
3464         if (!(o->op_flags & OPf_KIDS))
3465             break;
3466         doref(cLISTOPo->op_last, type, set_op_ref);
3467         break;
3468     default:
3469         break;
3470     }
3471     return scalar(o);
3472
3473 }
3474
3475 STATIC OP *
3476 S_dup_attrlist(pTHX_ OP *o)
3477 {
3478     OP *rop;
3479
3480     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3481
3482     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3483      * where the first kid is OP_PUSHMARK and the remaining ones
3484      * are OP_CONST.  We need to push the OP_CONST values.
3485      */
3486     if (o->op_type == OP_CONST)
3487         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3488     else {
3489         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3490         rop = NULL;
3491         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3492             if (o->op_type == OP_CONST)
3493                 rop = op_append_elem(OP_LIST, rop,
3494                                   newSVOP(OP_CONST, o->op_flags,
3495                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3496         }
3497     }
3498     return rop;
3499 }
3500
3501 STATIC void
3502 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3503 {
3504     PERL_ARGS_ASSERT_APPLY_ATTRS;
3505     {
3506         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3507
3508         /* fake up C<use attributes $pkg,$rv,@attrs> */
3509
3510 #define ATTRSMODULE "attributes"
3511 #define ATTRSMODULE_PM "attributes.pm"
3512
3513         Perl_load_module(
3514           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3515           newSVpvs(ATTRSMODULE),
3516           NULL,
3517           op_prepend_elem(OP_LIST,
3518                           newSVOP(OP_CONST, 0, stashsv),
3519                           op_prepend_elem(OP_LIST,
3520                                           newSVOP(OP_CONST, 0,
3521                                                   newRV(target)),
3522                                           dup_attrlist(attrs))));
3523     }
3524 }
3525
3526 STATIC void
3527 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3528 {
3529     OP *pack, *imop, *arg;
3530     SV *meth, *stashsv, **svp;
3531
3532     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3533
3534     if (!attrs)
3535         return;
3536
3537     assert(target->op_type == OP_PADSV ||
3538            target->op_type == OP_PADHV ||
3539            target->op_type == OP_PADAV);
3540
3541     /* Ensure that attributes.pm is loaded. */
3542     /* Don't force the C<use> if we don't need it. */
3543     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3544     if (svp && *svp != &PL_sv_undef)
3545         NOOP;   /* already in %INC */
3546     else
3547         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3548                                newSVpvs(ATTRSMODULE), NULL);
3549
3550     /* Need package name for method call. */
3551     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3552
3553     /* Build up the real arg-list. */
3554     stashsv = newSVhek(HvNAME_HEK(stash));
3555
3556     arg = newOP(OP_PADSV, 0);
3557     arg->op_targ = target->op_targ;
3558     arg = op_prepend_elem(OP_LIST,
3559                        newSVOP(OP_CONST, 0, stashsv),
3560                        op_prepend_elem(OP_LIST,
3561                                     newUNOP(OP_REFGEN, 0,
3562                                             arg),
3563                                     dup_attrlist(attrs)));
3564
3565     /* Fake up a method call to import */
3566     meth = newSVpvs_share("import");
3567     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3568                    op_append_elem(OP_LIST,
3569                                op_prepend_elem(OP_LIST, pack, arg),
3570                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3571
3572     /* Combine the ops. */
3573     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3574 }
3575
3576 /*
3577 =notfor apidoc apply_attrs_string
3578
3579 Attempts to apply a list of attributes specified by the C<attrstr> and
3580 C<len> arguments to the subroutine identified by the C<cv> argument which
3581 is expected to be associated with the package identified by the C<stashpv>
3582 argument (see L<attributes>).  It gets this wrong, though, in that it
3583 does not correctly identify the boundaries of the individual attribute
3584 specifications within C<attrstr>.  This is not really intended for the
3585 public API, but has to be listed here for systems such as AIX which
3586 need an explicit export list for symbols.  (It's called from XS code
3587 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3588 to respect attribute syntax properly would be welcome.
3589
3590 =cut
3591 */
3592
3593 void
3594 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3595                         const char *attrstr, STRLEN len)
3596 {
3597     OP *attrs = NULL;
3598
3599     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3600
3601     if (!len) {
3602         len = strlen(attrstr);
3603     }
3604
3605     while (len) {
3606         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3607         if (len) {
3608             const char * const sstr = attrstr;
3609             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3610             attrs = op_append_elem(OP_LIST, attrs,
3611                                 newSVOP(OP_CONST, 0,
3612                                         newSVpvn(sstr, attrstr-sstr)));
3613         }
3614     }
3615
3616     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3617                      newSVpvs(ATTRSMODULE),
3618                      NULL, op_prepend_elem(OP_LIST,
3619                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3620                                   op_prepend_elem(OP_LIST,
3621                                                newSVOP(OP_CONST, 0,
3622                                                        newRV(MUTABLE_SV(cv))),
3623                                                attrs)));
3624 }
3625
3626 STATIC void
3627 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3628 {
3629     OP *new_proto = NULL;
3630     STRLEN pvlen;
3631     char *pv;
3632     OP *o;
3633
3634     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3635
3636     if (!*attrs)
3637         return;
3638
3639     o = *attrs;
3640     if (o->op_type == OP_CONST) {
3641         pv = SvPV(cSVOPo_sv, pvlen);
3642         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3643             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3644             SV ** const tmpo = cSVOPx_svp(o);
3645             SvREFCNT_dec(cSVOPo_sv);
3646             *tmpo = tmpsv;
3647             new_proto = o;
3648             *attrs = NULL;
3649         }
3650     } else if (o->op_type == OP_LIST) {
3651         OP * lasto;
3652         assert(o->op_flags & OPf_KIDS);
3653         lasto = cLISTOPo->op_first;
3654         assert(lasto->op_type == OP_PUSHMARK);
3655         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3656             if (o->op_type == OP_CONST) {
3657                 pv = SvPV(cSVOPo_sv, pvlen);
3658                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3659                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3660                     SV ** const tmpo = cSVOPx_svp(o);
3661                     SvREFCNT_dec(cSVOPo_sv);
3662                     *tmpo = tmpsv;
3663                     if (new_proto && ckWARN(WARN_MISC)) {
3664                         STRLEN new_len;
3665                         const char * newp = SvPV(cSVOPo_sv, new_len);
3666                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3667                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3668                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3669                         op_free(new_proto);
3670                     }
3671                     else if (new_proto)
3672                         op_free(new_proto);
3673                     new_proto = o;
3674                     /* excise new_proto from the list */
3675                     op_sibling_splice(*attrs, lasto, 1, NULL);
3676                     o = lasto;
3677                     continue;
3678                 }
3679             }
3680             lasto = o;
3681         }
3682         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3683            would get pulled in with no real need */
3684         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3685             op_free(*attrs);
3686             *attrs = NULL;
3687         }
3688     }
3689
3690     if (new_proto) {
3691         SV *svname;
3692         if (isGV(name)) {
3693             svname = sv_newmortal();
3694             gv_efullname3(svname, name, NULL);
3695         }
3696         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3697             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3698         else
3699             svname = (SV *)name;
3700         if (ckWARN(WARN_ILLEGALPROTO))
3701             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3702         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3703             STRLEN old_len, new_len;
3704             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3705             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3706
3707             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3708                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3709                 " in %"SVf,
3710                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3711                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3712                 SVfARG(svname));
3713         }
3714         if (*proto)
3715             op_free(*proto);
3716         *proto = new_proto;
3717     }
3718 }
3719
3720 static void
3721 S_cant_declare(pTHX_ OP *o)
3722 {
3723     if (o->op_type == OP_NULL
3724      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3725         o = cUNOPo->op_first;
3726     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3727                              o->op_type == OP_NULL
3728                                && o->op_flags & OPf_SPECIAL
3729                                  ? "do block"
3730                                  : OP_DESC(o),
3731                              PL_parser->in_my == KEY_our   ? "our"   :
3732                              PL_parser->in_my == KEY_state ? "state" :
3733                                                              "my"));
3734 }
3735
3736 STATIC OP *
3737 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3738 {
3739     I32 type;
3740     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3741
3742     PERL_ARGS_ASSERT_MY_KID;
3743
3744     if (!o || (PL_parser && PL_parser->error_count))
3745         return o;
3746
3747     type = o->op_type;
3748
3749     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3750         OP *kid;
3751         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3752             my_kid(kid, attrs, imopsp);
3753         return o;
3754     } else if (type == OP_UNDEF || type == OP_STUB) {
3755         return o;
3756     } else if (type == OP_RV2SV ||      /* "our" declaration */
3757                type == OP_RV2AV ||
3758                type == OP_RV2HV) {
3759         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3760             S_cant_declare(aTHX_ o);
3761         } else if (attrs) {
3762             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3763             assert(PL_parser);
3764             PL_parser->in_my = FALSE;
3765             PL_parser->in_my_stash = NULL;
3766             apply_attrs(GvSTASH(gv),
3767                         (type == OP_RV2SV ? GvSV(gv) :
3768                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3769                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3770                         attrs);
3771         }
3772         o->op_private |= OPpOUR_INTRO;
3773         return o;
3774     }
3775     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3776         /* Kid is a nulled OP_LIST, handled above.  */
3777         my_kid(cUNOPo->op_first, attrs, imopsp);
3778         return o;
3779     }
3780     else if (type != OP_PADSV &&
3781              type != OP_PADAV &&
3782              type != OP_PADHV &&
3783              type != OP_PUSHMARK)
3784     {
3785         S_cant_declare(aTHX_ o);
3786         return o;
3787     }
3788     else if (attrs && type != OP_PUSHMARK) {
3789         HV *stash;
3790
3791         assert(PL_parser);
3792         PL_parser->in_my = FALSE;
3793         PL_parser->in_my_stash = NULL;
3794
3795         /* check for C<my Dog $spot> when deciding package */
3796         stash = PAD_COMPNAME_TYPE(o->op_targ);
3797         if (!stash)
3798             stash = PL_curstash;
3799         apply_attrs_my(stash, o, attrs, imopsp);
3800     }
3801     o->op_flags |= OPf_MOD;
3802     o->op_private |= OPpLVAL_INTRO;
3803     if (stately)
3804         o->op_private |= OPpPAD_STATE;
3805     return o;
3806 }
3807
3808 OP *
3809 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3810 {
3811     OP *rops;
3812     int maybe_scalar = 0;
3813
3814     PERL_ARGS_ASSERT_MY_ATTRS;
3815
3816 /* [perl #17376]: this appears to be premature, and results in code such as
3817    C< our(%x); > executing in list mode rather than void mode */
3818 #if 0
3819     if (o->op_flags & OPf_PARENS)
3820         list(o);
3821     else
3822         maybe_scalar = 1;
3823 #else
3824     maybe_scalar = 1;
3825 #endif
3826     if (attrs)
3827         SAVEFREEOP(attrs);
3828     rops = NULL;
3829     o = my_kid(o, attrs, &rops);
3830     if (rops) {
3831         if (maybe_scalar && o->op_type == OP_PADSV) {
3832             o = scalar(op_append_list(OP_LIST, rops, o));
3833             o->op_private |= OPpLVAL_INTRO;
3834         }
3835         else {
3836             /* The listop in rops might have a pushmark at the beginning,
3837                which will mess up list assignment. */
3838             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3839             if (rops->op_type == OP_LIST && 
3840                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3841             {
3842                 OP * const pushmark = lrops->op_first;
3843                 /* excise pushmark */
3844                 op_sibling_splice(rops, NULL, 1, NULL);
3845                 op_free(pushmark);
3846             }
3847             o = op_append_list(OP_LIST, o, rops);
3848         }
3849     }
3850     PL_parser->in_my = FALSE;
3851     PL_parser->in_my_stash = NULL;
3852     return o;
3853 }
3854
3855 OP *
3856 Perl_sawparens(pTHX_ OP *o)
3857 {
3858     PERL_UNUSED_CONTEXT;
3859     if (o)
3860         o->op_flags |= OPf_PARENS;
3861     return o;
3862 }
3863
3864 OP *
3865 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3866 {
3867     OP *o;
3868     bool ismatchop = 0;
3869     const OPCODE ltype = left->op_type;
3870     const OPCODE rtype = right->op_type;
3871
3872     PERL_ARGS_ASSERT_BIND_MATCH;
3873
3874     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3875           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3876     {
3877       const char * const desc
3878           = PL_op_desc[(
3879                           rtype == OP_SUBST || rtype == OP_TRANS
3880                        || rtype == OP_TRANSR
3881                        )
3882                        ? (int)rtype : OP_MATCH];
3883       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3884       SV * const name =
3885         S_op_varname(aTHX_ left);
3886       if (name)
3887         Perl_warner(aTHX_ packWARN(WARN_MISC),
3888              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3889              desc, SVfARG(name), SVfARG(name));
3890       else {
3891         const char * const sample = (isary
3892              ? "@array" : "%hash");
3893         Perl_warner(aTHX_ packWARN(WARN_MISC),
3894              "Applying %s to %s will act on scalar(%s)",
3895              desc, sample, sample);
3896       }
3897     }
3898
3899     if (rtype == OP_CONST &&
3900         cSVOPx(right)->op_private & OPpCONST_BARE &&
3901         cSVOPx(right)->op_private & OPpCONST_STRICT)
3902     {
3903         no_bareword_allowed(right);
3904     }
3905
3906     /* !~ doesn't make sense with /r, so error on it for now */
3907     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3908         type == OP_NOT)
3909         /* diag_listed_as: Using !~ with %s doesn't make sense */
3910         yyerror("Using !~ with s///r doesn't make sense");
3911     if (rtype == OP_TRANSR && type == OP_NOT)
3912         /* diag_listed_as: Using !~ with %s doesn't make sense */
3913         yyerror("Using !~ with tr///r doesn't make sense");
3914
3915     ismatchop = (rtype == OP_MATCH ||
3916                  rtype == OP_SUBST ||
3917                  rtype == OP_TRANS || rtype == OP_TRANSR)
3918              && !(right->op_flags & OPf_SPECIAL);
3919     if (ismatchop && right->op_private & OPpTARGET_MY) {
3920         right->op_targ = 0;
3921         right->op_private &= ~OPpTARGET_MY;
3922     }
3923     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3924         if (left->op_type == OP_PADSV
3925          && !(left->op_private & OPpLVAL_INTRO))
3926         {
3927             right->op_targ = left->op_targ;
3928             op_free(left);
3929             o = right;
3930         }
3931         else {
3932             right->op_flags |= OPf_STACKED;
3933             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3934             ! (rtype == OP_TRANS &&
3935                right->op_private & OPpTRANS_IDENTICAL) &&
3936             ! (rtype == OP_SUBST &&
3937                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3938                 left = op_lvalue(left, rtype);
3939             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3940                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3941             else
3942                 o = op_prepend_elem(rtype, scalar(left), right);
3943         }
3944         if (type == OP_NOT)
3945             return newUNOP(OP_NOT, 0, scalar(o));
3946         return o;
3947     }
3948     else
3949         return bind_match(type, left,
3950                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3951 }
3952
3953 OP *
3954 Perl_invert(pTHX_ OP *o)
3955 {
3956     if (!o)
3957         return NULL;
3958     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3959 }
3960
3961 /*
3962 =for apidoc Amx|OP *|op_scope|OP *o
3963
3964 Wraps up an op tree with some additional ops so that at runtime a dynamic
3965 scope will be created.  The original ops run in the new dynamic scope,
3966 and then, provided that they exit normally, the scope will be unwound.
3967 The additional ops used to create and unwind the dynamic scope will
3968 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3969 instead if the ops are simple enough to not need the full dynamic scope
3970 structure.
3971
3972 =cut
3973 */
3974
3975 OP *
3976 Perl_op_scope(pTHX_ OP *o)
3977 {
3978     dVAR;
3979     if (o) {
3980         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3981             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3982             OpTYPE_set(o, OP_LEAVE);
3983         }
3984         else if (o->op_type == OP_LINESEQ) {
3985             OP *kid;
3986             OpTYPE_set(o, OP_SCOPE);
3987             kid = ((LISTOP*)o)->op_first;
3988             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3989                 op_null(kid);
3990
3991                 /* The following deals with things like 'do {1 for 1}' */
3992                 kid = OpSIBLING(kid);
3993                 if (kid &&
3994                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3995                     op_null(kid);
3996             }
3997         }
3998         else
3999             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4000     }
4001     return o;
4002 }
4003
4004 OP *
4005 Perl_op_unscope(pTHX_ OP *o)
4006 {
4007     if (o && o->op_type == OP_LINESEQ) {
4008         OP *kid = cLISTOPo->op_first;
4009         for(; kid; kid = OpSIBLING(kid))
4010             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4011                 op_null(kid);
4012     }
4013     return o;
4014 }
4015
4016 /*
4017 =for apidoc Am|int|block_start|int full
4018
4019 Handles compile-time scope entry.
4020 Arranges for hints to be restored on block
4021 exit and also handles pad sequence numbers to make lexical variables scope
4022 right.  Returns a savestack index for use with C<block_end>.
4023
4024 =cut
4025 */
4026
4027 int
4028 Perl_block_start(pTHX_ int full)
4029 {
4030     const int retval = PL_savestack_ix;
4031
4032     PL_compiling.cop_seq = PL_cop_seqmax;
4033     COP_SEQMAX_INC;
4034     pad_block_start(full);
4035     SAVEHINTS();
4036     PL_hints &= ~HINT_BLOCK_SCOPE;
4037     SAVECOMPILEWARNINGS();
4038     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4039     SAVEI32(PL_compiling.cop_seq);
4040     PL_compiling.cop_seq = 0;
4041
4042     CALL_BLOCK_HOOKS(bhk_start, full);
4043
4044     return retval;
4045 }
4046
4047 /*
4048 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4049
4050 Handles compile-time scope exit.  C<floor>
4051 is the savestack index returned by
4052 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4053 possibly modified.
4054
4055 =cut
4056 */
4057
4058 OP*
4059 Perl_block_end(pTHX_ I32 floor, OP *seq)
4060 {
4061     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4062     OP* retval = scalarseq(seq);
4063     OP *o;
4064
4065     /* XXX Is the null PL_parser check necessary here? */
4066     assert(PL_parser); /* Let’s find out under debugging builds.  */
4067     if (PL_parser && PL_parser->parsed_sub) {
4068         o = newSTATEOP(0, NULL, NULL);
4069         op_null(o);
4070         retval = op_append_elem(OP_LINESEQ, retval, o);
4071     }
4072
4073     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4074
4075     LEAVE_SCOPE(floor);
4076     if (needblockscope)
4077         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4078     o = pad_leavemy();
4079
4080     if (o) {
4081         /* pad_leavemy has created a sequence of introcv ops for all my
4082            subs declared in the block.  We have to replicate that list with
4083            clonecv ops, to deal with this situation:
4084
4085                sub {
4086                    my sub s1;
4087                    my sub s2;
4088                    sub s1 { state sub foo { \&s2 } }
4089                }->()
4090
4091            Originally, I was going to have introcv clone the CV and turn
4092            off the stale flag.  Since &s1 is declared before &s2, the
4093            introcv op for &s1 is executed (on sub entry) before the one for
4094            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4095            cloned, since it is a state sub) closes over &s2 and expects
4096            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4097            then &s2 is still marked stale.  Since &s1 is not active, and
4098            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4099            ble will not stay shared’ warning.  Because it is the same stub
4100            that will be used when the introcv op for &s2 is executed, clos-
4101            ing over it is safe.  Hence, we have to turn off the stale flag
4102            on all lexical subs in the block before we clone any of them.
4103            Hence, having introcv clone the sub cannot work.  So we create a
4104            list of ops like this:
4105
4106                lineseq
4107                   |
4108                   +-- introcv
4109                   |
4110                   +-- introcv
4111                   |
4112                   +-- introcv
4113                   |
4114                   .
4115                   .
4116                   .
4117                   |
4118                   +-- clonecv
4119                   |
4120                   +-- clonecv
4121                   |
4122                   +-- clonecv
4123                   |
4124                   .
4125                   .
4126                   .
4127          */
4128         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4129         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4130         for (;; kid = OpSIBLING(kid)) {
4131             OP *newkid = newOP(OP_CLONECV, 0);
4132             newkid->op_targ = kid->op_targ;
4133             o = op_append_elem(OP_LINESEQ, o, newkid);
4134             if (kid == last) break;
4135         }
4136         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4137     }
4138
4139     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4140
4141     return retval;
4142 }
4143
4144 /*
4145 =head1 Compile-time scope hooks
4146
4147 =for apidoc Aox||blockhook_register
4148
4149 Register a set of hooks to be called when the Perl lexical scope changes
4150 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4151
4152 =cut
4153 */
4154
4155 void
4156 Perl_blockhook_register(pTHX_ BHK *hk)
4157 {
4158     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4159
4160     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4161 }
4162
4163 void
4164 Perl_newPROG(pTHX_ OP *o)
4165 {
4166     PERL_ARGS_ASSERT_NEWPROG;
4167
4168     if (PL_in_eval) {
4169         PERL_CONTEXT *cx;
4170         I32 i;
4171         if (PL_eval_root)
4172                 return;
4173         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4174                                ((PL_in_eval & EVAL_KEEPERR)
4175                                 ? OPf_SPECIAL : 0), o);
4176
4177         cx = CX_CUR();
4178         assert(CxTYPE(cx) == CXt_EVAL);
4179
4180         if ((cx->blk_gimme & G_WANT) == G_VOID)
4181             scalarvoid(PL_eval_root);
4182         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4183             list(PL_eval_root);
4184         else
4185             scalar(PL_eval_root);
4186
4187         PL_eval_start = op_linklist(PL_eval_root);
4188         PL_eval_root->op_private |= OPpREFCOUNTED;
4189         OpREFCNT_set(PL_eval_root, 1);
4190         PL_eval_root->op_next = 0;
4191         i = PL_savestack_ix;
4192         SAVEFREEOP(o);
4193         ENTER;
4194         CALL_PEEP(PL_eval_start);
4195         finalize_optree(PL_eval_root);
4196         S_prune_chain_head(&PL_eval_start);
4197         LEAVE;
4198         PL_savestack_ix = i;
4199     }
4200     else {
4201         if (o->op_type == OP_STUB) {
4202             /* This block is entered if nothing is compiled for the main
4203                program. This will be the case for an genuinely empty main
4204                program, or one which only has BEGIN blocks etc, so already
4205                run and freed.
4206
4207                Historically (5.000) the guard above was !o. However, commit
4208                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4209                c71fccf11fde0068, changed perly.y so that newPROG() is now
4210                called with the output of block_end(), which returns a new
4211                OP_STUB for the case of an empty optree. ByteLoader (and
4212                maybe other things) also take this path, because they set up
4213                PL_main_start and PL_main_root directly, without generating an
4214                optree.
4215
4216                If the parsing the main program aborts (due to parse errors,
4217                or due to BEGIN or similar calling exit), then newPROG()
4218                isn't even called, and hence this code path and its cleanups
4219                are skipped. This shouldn't make a make a difference:
4220                * a non-zero return from perl_parse is a failure, and
4221                  perl_destruct() should be called immediately.
4222                * however, if exit(0) is called during the parse, then
4223                  perl_parse() returns 0, and perl_run() is called. As
4224                  PL_main_start will be NULL, perl_run() will return
4225                  promptly, and the exit code will remain 0.
4226             */
4227
4228             PL_comppad_name = 0;
4229             PL_compcv = 0;
4230             S_op_destroy(aTHX_ o);
4231             return;
4232         }
4233         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4234         PL_curcop = &PL_compiling;
4235         PL_main_start = LINKLIST(PL_main_root);
4236         PL_main_root->op_private |= OPpREFCOUNTED;
4237         OpREFCNT_set(PL_main_root, 1);
4238         PL_main_root->op_next = 0;
4239         CALL_PEEP(PL_main_start);
4240         finalize_optree(PL_main_root);
4241         S_prune_chain_head(&PL_main_start);
4242         cv_forget_slab(PL_compcv);
4243         PL_compcv = 0;
4244
4245         /* Register with debugger */
4246         if (PERLDB_INTER) {
4247             CV * const cv = get_cvs("DB::postponed", 0);
4248             if (cv) {
4249                 dSP;
4250                 PUSHMARK(SP);
4251                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4252                 PUTBACK;
4253                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4254             }
4255         }
4256     }
4257 }
4258
4259 OP *
4260 Perl_localize(pTHX_ OP *o, I32 lex)
4261 {
4262     PERL_ARGS_ASSERT_LOCALIZE;
4263
4264     if (o->op_flags & OPf_PARENS)
4265 /* [perl #17376]: this appears to be premature, and results in code such as
4266    C< our(%x); > executing in list mode rather than void mode */
4267 #if 0
4268         list(o);
4269 #else
4270         NOOP;
4271 #endif
4272     else {
4273         if ( PL_parser->bufptr > PL_parser->oldbufptr
4274             && PL_parser->bufptr[-1] == ','
4275             && ckWARN(WARN_PARENTHESIS))
4276         {
4277             char *s = PL_parser->bufptr;
4278             bool sigil = FALSE;
4279
4280             /* some heuristics to detect a potential error */
4281             while (*s && (strchr(", \t\n", *s)))
4282                 s++;
4283
4284             while (1) {
4285                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4286                        && *++s
4287                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4288                     s++;
4289                     sigil = TRUE;
4290                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4291                         s++;
4292                     while (*s && (strchr(", \t\n", *s)))
4293                         s++;
4294                 }
4295                 else
4296                     break;
4297             }
4298             if (sigil && (*s == ';' || *s == '=')) {
4299                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4300                                 "Parentheses missing around \"%s\" list",
4301                                 lex
4302                                     ? (PL_parser->in_my == KEY_our
4303                                         ? "our"
4304                                         : PL_parser->in_my == KEY_state
4305                                             ? "state"
4306                                             : "my")
4307                                     : "local");
4308             }
4309         }
4310     }
4311     if (lex)
4312         o = my(o);
4313     else
4314         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4315     PL_parser->in_my = FALSE;
4316     PL_parser->in_my_stash = NULL;
4317     return o;
4318 }
4319
4320 OP *
4321 Perl_jmaybe(pTHX_ OP *o)
4322 {
4323     PERL_ARGS_ASSERT_JMAYBE;
4324
4325     if (o->op_type == OP_LIST) {
4326         OP * const o2
4327             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4328         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4329     }
4330     return o;
4331 }
4332
4333 PERL_STATIC_INLINE OP *
4334 S_op_std_init(pTHX_ OP *o)
4335 {
4336     I32 type = o->op_type;
4337
4338     PERL_ARGS_ASSERT_OP_STD_INIT;
4339
4340     if (PL_opargs[type] & OA_RETSCALAR)
4341         scalar(o);
4342     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4343         o->op_targ = pad_alloc(type, SVs_PADTMP);
4344
4345     return o;
4346 }
4347
4348 PERL_STATIC_INLINE OP *
4349 S_op_integerize(pTHX_ OP *o)
4350 {
4351     I32 type = o->op_type;
4352
4353     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4354
4355     /* integerize op. */
4356     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4357     {
4358         dVAR;
4359         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4360     }
4361
4362     if (type == OP_NEGATE)
4363         /* XXX might want a ck_negate() for this */
4364         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4365
4366     return o;
4367 }
4368
4369 static OP *
4370 S_fold_constants(pTHX_ OP *o)
4371 {
4372     dVAR;
4373     OP * VOL curop;
4374     OP *newop;
4375     VOL I32 type = o->op_type;
4376     bool is_stringify;
4377     SV * VOL sv = NULL;
4378     int ret = 0;
4379     OP *old_next;
4380     SV * const oldwarnhook = PL_warnhook;
4381     SV * const olddiehook  = PL_diehook;
4382     COP not_compiling;
4383     U8 oldwarn = PL_dowarn;
4384     I32 old_cxix;
4385     dJMPENV;
4386
4387     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4388
4389     if (!(PL_opargs[type] & OA_FOLDCONST))
4390         goto nope;
4391
4392     switch (type) {
4393     case OP_UCFIRST:
4394     case OP_LCFIRST:
4395     case OP_UC:
4396     case OP_LC:
4397     case OP_FC:
4398 #ifdef USE_LOCALE_CTYPE
4399         if (IN_LC_COMPILETIME(LC_CTYPE))
4400             goto nope;
4401 #endif
4402         break;
4403     case OP_SLT:
4404     case OP_SGT:
4405     case OP_SLE:
4406     case OP_SGE:
4407     case OP_SCMP:
4408 #ifdef USE_LOCALE_COLLATE
4409         if (IN_LC_COMPILETIME(LC_COLLATE))
4410             goto nope;
4411 #endif
4412         break;
4413     case OP_SPRINTF:
4414         /* XXX what about the numeric ops? */
4415 #ifdef USE_LOCALE_NUMERIC
4416         if (IN_LC_COMPILETIME(LC_NUMERIC))
4417             goto nope;
4418 #endif
4419         break;
4420     case OP_PACK:
4421         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4422           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4423             goto nope;
4424         {
4425             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4426             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4427             {
4428                 const char *s = SvPVX_const(sv);
4429                 while (s < SvEND(sv)) {
4430                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4431                     s++;
4432                 }
4433             }
4434         }
4435         break;
4436     case OP_REPEAT:
4437         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4438         break;
4439     case OP_SREFGEN:
4440         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4441          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4442             goto nope;
4443     }
4444
4445     if (PL_parser && PL_parser->error_count)
4446         goto nope;              /* Don't try to run w/ errors */
4447
4448     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4449         switch (curop->op_type) {
4450         case OP_CONST:
4451             if (   (curop->op_private & OPpCONST_BARE)
4452                 && (curop->op_private & OPpCONST_STRICT)) {
4453                 no_bareword_allowed(curop);
4454                 goto nope;
4455             }
4456             /* FALLTHROUGH */
4457         case OP_LIST:
4458         case OP_SCALAR:
4459         case OP_NULL:
4460         case OP_PUSHMARK:
4461             /* Foldable; move to next op in list */
4462             break;
4463
4464         default:
4465             /* No other op types are considered foldable */
4466             goto nope;
4467         }
4468     }
4469
4470     curop = LINKLIST(o);
4471     old_next = o->op_next;
4472     o->op_next = 0;
4473     PL_op = curop;
4474
4475     old_cxix = cxstack_ix;
4476     create_eval_scope(NULL, G_FAKINGEVAL);
4477
4478     /* Verify that we don't need to save it:  */
4479     assert(PL_curcop == &PL_compiling);
4480     StructCopy(&PL_compiling, &not_compiling, COP);
4481     PL_curcop = &not_compiling;
4482     /* The above ensures that we run with all the correct hints of the
4483        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4484     assert(IN_PERL_RUNTIME);
4485     PL_warnhook = PERL_WARNHOOK_FATAL;
4486     PL_diehook  = NULL;
4487     JMPENV_PUSH(ret);
4488
4489     /* Effective $^W=1.  */
4490     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4491         PL_dowarn |= G_WARN_ON;
4492
4493     switch (ret) {
4494     case 0:
4495         CALLRUNOPS(aTHX);
4496         sv = *(PL_stack_sp--);
4497         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4498             pad_swipe(o->op_targ,  FALSE);
4499         }
4500         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4501             SvREFCNT_inc_simple_void(sv);
4502             SvTEMP_off(sv);
4503         }
4504         else { assert(SvIMMORTAL(sv)); }
4505         break;
4506     case 3:
4507         /* Something tried to die.  Abandon constant folding.  */
4508         /* Pretend the error never happened.  */
4509         CLEAR_ERRSV();
4510         o->op_next = old_next;
4511         break;
4512     default:
4513         JMPENV_POP;
4514         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4515         PL_warnhook = oldwarnhook;
4516         PL_diehook  = olddiehook;
4517         /* XXX note that this croak may fail as we've already blown away
4518          * the stack - eg any nested evals */
4519         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4520     }
4521     JMPENV_POP;
4522     PL_dowarn   = oldwarn;
4523     PL_warnhook = oldwarnhook;
4524     PL_diehook  = olddiehook;
4525     PL_curcop = &PL_compiling;
4526
4527     /* if we croaked, depending on how we croaked the eval scope
4528      * may or may not have already been popped */
4529     if (cxstack_ix > old_cxix) {
4530         assert(cxstack_ix == old_cxix + 1);
4531         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4532         delete_eval_scope();
4533     }
4534     if (ret)
4535         goto nope;
4536
4537     /* OP_STRINGIFY and constant folding are used to implement qq.
4538        Here the constant folding is an implementation detail that we
4539        want to hide.  If the stringify op is itself already marked
4540        folded, however, then it is actually a folded join.  */
4541     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4542     op_free(o);
4543     assert(sv);
4544     if (is_stringify)
4545         SvPADTMP_off(sv);
4546     else if (!SvIMMORTAL(sv)) {
4547         SvPADTMP_on(sv);
4548         SvREADONLY_on(sv);
4549     }
4550     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4551     if (!is_stringify) newop->op_folded = 1;
4552     return newop;
4553
4554  nope:
4555     return o;
4556 }
4557
4558 static OP *
4559 S_gen_constant_list(pTHX_ OP *o)
4560 {
4561     dVAR;
4562     OP *curop;
4563     const SSize_t oldtmps_floor = PL_tmps_floor;
4564     SV **svp;
4565     AV *av;
4566
4567     list(o);
4568     if (PL_parser && PL_parser->error_count)
4569         return o;               /* Don't attempt to run with errors */
4570
4571     curop = LINKLIST(o);
4572     o->op_next = 0;
4573     CALL_PEEP(curop);
4574     S_prune_chain_head(&curop);
4575     PL_op = curop;
4576     Perl_pp_pushmark(aTHX);
4577     CALLRUNOPS(aTHX);
4578     PL_op = curop;
4579     assert (!(curop->op_flags & OPf_SPECIAL));
4580     assert(curop->op_type == OP_RANGE);
4581     Perl_pp_anonlist(aTHX);
4582     PL_tmps_floor = oldtmps_floor;
4583
4584     OpTYPE_set(o, OP_RV2AV);
4585     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4586     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4587     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4588     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4589
4590     /* replace subtree with an OP_CONST */
4591     curop = ((UNOP*)o)->op_first;
4592     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4593     op_free(curop);
4594
4595     if (AvFILLp(av) != -1)
4596         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4597         {
4598             SvPADTMP_on(*svp);
4599             SvREADONLY_on(*svp);
4600         }
4601     LINKLIST(o);
4602     return list(o);
4603 }
4604
4605 /*
4606 =head1 Optree Manipulation Functions
4607 */
4608
4609 /* List constructors */
4610
4611 /*
4612 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4613
4614 Append an item to the list of ops contained directly within a list-type
4615 op, returning the lengthened list.  C<first> is the list-type op,
4616 and C<last> is the op to append to the list.  C<optype> specifies the
4617 intended opcode for the list.  If C<first> is not already a list of the
4618 right type, it will be upgraded into one.  If either C<first> or C<last>
4619 is null, the other is returned unchanged.
4620
4621 =cut
4622 */
4623
4624 OP *
4625 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4626 {
4627     if (!first)
4628         return last;
4629
4630     if (!last)
4631         return first;
4632
4633     if (first->op_type != (unsigned)type
4634         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4635     {
4636         return newLISTOP(type, 0, first, last);
4637     }
4638
4639     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4640     first->op_flags |= OPf_KIDS;
4641     return first;
4642 }
4643
4644 /*
4645 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4646
4647 Concatenate the lists of ops contained directly within two list-type ops,
4648 returning the combined list.  C<first> and C<last> are the list-type ops
4649 to concatenate.  C<optype> specifies the intended opcode for the list.
4650 If either C<first> or C<last> is not already a list of the right type,
4651 it will be upgraded into one.  If either C<first> or C<last> is null,
4652 the other is returned unchanged.
4653
4654 =cut
4655 */
4656
4657 OP *
4658 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4659 {
4660     if (!first)
4661         return last;
4662
4663     if (!last)
4664         return first;
4665
4666     if (first->op_type != (unsigned)type)
4667         return op_prepend_elem(type, first, last);
4668
4669     if (last->op_type != (unsigned)type)
4670         return op_append_elem(type, first, last);
4671
4672     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4673     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4674     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4675     first->op_flags |= (last->op_flags & OPf_KIDS);
4676
4677     S_op_destroy(aTHX_ last);
4678
4679     return first;
4680 }
4681
4682 /*
4683 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4684
4685 Prepend an item to the list of ops contained directly within a list-type
4686 op, returning the lengthened list.  C<first> is the op to prepend to the
4687 list, and C<last> is the list-type op.  C<optype> specifies the intended
4688 opcode for the list.  If C<last> is not already a list of the right type,
4689 it will be upgraded into one.  If either C<first> or C<last> is null,
4690 the other is returned unchanged.
4691
4692 =cut
4693 */
4694
4695 OP *
4696 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4697 {
4698     if (!first)
4699         return last;
4700
4701     if (!last)
4702         return first;
4703
4704     if (last->op_type == (unsigned)type) {
4705         if (type == OP_LIST) {  /* already a PUSHMARK there */
4706             /* insert 'first' after pushmark */
4707             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4708             if (!(first->op_flags & OPf_PARENS))
4709                 last->op_flags &= ~OPf_PARENS;
4710         }
4711         else
4712             op_sibling_splice(last, NULL, 0, first);
4713         last->op_flags |= OPf_KIDS;
4714         return last;
4715     }
4716
4717     return newLISTOP(type, 0, first, last);
4718 }
4719
4720 /*
4721 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4722
4723 Converts C<o> into a list op if it is not one already, and then converts it
4724 into the specified C<type>, calling its check function, allocating a target if
4725 it needs one, and folding constants.
4726
4727 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4728 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4729 C<op_convert_list> to make it the right type.
4730
4731 =cut
4732 */
4733
4734 OP *
4735 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4736 {
4737     dVAR;
4738     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4739     if (!o || o->op_type != OP_LIST)
4740         o = force_list(o, 0);
4741     else
4742     {
4743         o->op_flags &= ~OPf_WANT;
4744         o->op_private &= ~OPpLVAL_INTRO;
4745     }
4746
4747     if (!(PL_opargs[type] & OA_MARK))
4748         op_null(cLISTOPo->op_first);
4749     else {
4750         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4751         if (kid2 && kid2->op_type == OP_COREARGS) {
4752             op_null(cLISTOPo->op_first);
4753             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4754         }
4755     }
4756
4757     OpTYPE_set(o, type);
4758     o->op_flags |= flags;
4759     if (flags & OPf_FOLDED)
4760         o->op_folded = 1;
4761
4762     o = CHECKOP(type, o);
4763     if (o->op_type != (unsigned)type)
4764         return o;
4765
4766     return fold_constants(op_integerize(op_std_init(o)));
4767 }
4768
4769 /* Constructors */
4770
4771
4772 /*
4773 =head1 Optree construction
4774
4775 =for apidoc Am|OP *|newNULLLIST
4776
4777 Constructs, checks, and returns a new C<stub> op, which represents an
4778 empty list expression.
4779
4780 =cut
4781 */
4782
4783 OP *
4784 Perl_newNULLLIST(pTHX)
4785 {
4786     return newOP(OP_STUB, 0);
4787 }
4788
4789 /* promote o and any siblings to be a list if its not already; i.e.
4790  *
4791  *  o - A - B
4792  *
4793  * becomes
4794  *
4795  *  list
4796  *    |
4797  *  pushmark - o - A - B
4798  *
4799  * If nullit it true, the list op is nulled.
4800  */
4801
4802 static OP *
4803 S_force_list(pTHX_ OP *o, bool nullit)
4804 {
4805     if (!o || o->op_type != OP_LIST) {
4806         OP *rest = NULL;
4807         if (o) {
4808             /* manually detach any siblings then add them back later */
4809             rest = OpSIBLING(o);
4810             OpLASTSIB_set(o, NULL);
4811         }
4812         o = newLISTOP(OP_LIST, 0, o, NULL);
4813         if (rest)
4814             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4815     }
4816     if (nullit)
4817         op_null(o);
4818     return o;
4819 }
4820
4821 /*
4822 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4823
4824 Constructs, checks, and returns an op of any list type.  C<type> is
4825 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4826 C<OPf_KIDS> will be set automatically if required.  C<fir