This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_newASSIGNOP: fix on g++ builds
[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     case OP_ARGDEFELEM: /* Was holding signature index. */
933         o->op_targ = 0;
934         break;
935     default:
936         if (!(o->op_flags & OPf_REF)
937             || (PL_check[o->op_type] != Perl_ck_ftst))
938             break;
939         /* FALLTHROUGH */
940     case OP_GVSV:
941     case OP_GV:
942     case OP_AELEMFAST:
943 #ifdef USE_ITHREADS
944             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
945 #else
946             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
947 #endif
948         break;
949     case OP_METHOD_REDIR:
950     case OP_METHOD_REDIR_SUPER:
951 #ifdef USE_ITHREADS
952         if (cMETHOPx(o)->op_rclass_targ) {
953             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
954             cMETHOPx(o)->op_rclass_targ = 0;
955         }
956 #else
957         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
958         cMETHOPx(o)->op_rclass_sv = NULL;
959 #endif
960     case OP_METHOD_NAMED:
961     case OP_METHOD_SUPER:
962         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
963         cMETHOPx(o)->op_u.op_meth_sv = NULL;
964 #ifdef USE_ITHREADS
965         if (o->op_targ) {
966             pad_swipe(o->op_targ, 1);
967             o->op_targ = 0;
968         }
969 #endif
970         break;
971     case OP_CONST:
972     case OP_HINTSEVAL:
973         SvREFCNT_dec(cSVOPo->op_sv);
974         cSVOPo->op_sv = NULL;
975 #ifdef USE_ITHREADS
976         /** Bug #15654
977           Even if op_clear does a pad_free for the target of the op,
978           pad_free doesn't actually remove the sv that exists in the pad;
979           instead it lives on. This results in that it could be reused as 
980           a target later on when the pad was reallocated.
981         **/
982         if(o->op_targ) {
983           pad_swipe(o->op_targ,1);
984           o->op_targ = 0;
985         }
986 #endif
987         break;
988     case OP_DUMP:
989     case OP_GOTO:
990     case OP_NEXT:
991     case OP_LAST:
992     case OP_REDO:
993         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
994             break;
995         /* FALLTHROUGH */
996     case OP_TRANS:
997     case OP_TRANSR:
998         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
999             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1000 #ifdef USE_ITHREADS
1001             if (cPADOPo->op_padix > 0) {
1002                 pad_swipe(cPADOPo->op_padix, TRUE);
1003                 cPADOPo->op_padix = 0;
1004             }
1005 #else
1006             SvREFCNT_dec(cSVOPo->op_sv);
1007             cSVOPo->op_sv = NULL;
1008 #endif
1009         }
1010         else {
1011             PerlMemShared_free(cPVOPo->op_pv);
1012             cPVOPo->op_pv = NULL;
1013         }
1014         break;
1015     case OP_SUBST:
1016         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1017         goto clear_pmop;
1018
1019     case OP_SPLIT:
1020         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1021             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1022         {
1023             if (o->op_private & OPpSPLIT_LEX)
1024                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1025             else
1026 #ifdef USE_ITHREADS
1027                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1028 #else
1029                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1030 #endif
1031         }
1032         /* FALLTHROUGH */
1033     case OP_MATCH:
1034     case OP_QR:
1035     clear_pmop:
1036         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1037             op_free(cPMOPo->op_code_list);
1038         cPMOPo->op_code_list = NULL;
1039         forget_pmop(cPMOPo);
1040         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1041         /* we use the same protection as the "SAFE" version of the PM_ macros
1042          * here since sv_clean_all might release some PMOPs
1043          * after PL_regex_padav has been cleared
1044          * and the clearing of PL_regex_padav needs to
1045          * happen before sv_clean_all
1046          */
1047 #ifdef USE_ITHREADS
1048         if(PL_regex_pad) {        /* We could be in destruction */
1049             const IV offset = (cPMOPo)->op_pmoffset;
1050             ReREFCNT_dec(PM_GETRE(cPMOPo));
1051             PL_regex_pad[offset] = &PL_sv_undef;
1052             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1053                            sizeof(offset));
1054         }
1055 #else
1056         ReREFCNT_dec(PM_GETRE(cPMOPo));
1057         PM_SETRE(cPMOPo, NULL);
1058 #endif
1059
1060         break;
1061
1062     case OP_ARGCHECK:
1063         PerlMemShared_free(cUNOP_AUXo->op_aux);
1064         break;
1065
1066     case OP_MULTIDEREF:
1067         {
1068             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1069             UV actions = items->uv;
1070             bool last = 0;
1071             bool is_hash = FALSE;
1072
1073             while (!last) {
1074                 switch (actions & MDEREF_ACTION_MASK) {
1075
1076                 case MDEREF_reload:
1077                     actions = (++items)->uv;
1078                     continue;
1079
1080                 case MDEREF_HV_padhv_helem:
1081                     is_hash = TRUE;
1082                 case MDEREF_AV_padav_aelem:
1083                     pad_free((++items)->pad_offset);
1084                     goto do_elem;
1085
1086                 case MDEREF_HV_gvhv_helem:
1087                     is_hash = TRUE;
1088                 case MDEREF_AV_gvav_aelem:
1089 #ifdef USE_ITHREADS
1090                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1091 #else
1092                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1093 #endif
1094                     goto do_elem;
1095
1096                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1097                     is_hash = TRUE;
1098                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1099 #ifdef USE_ITHREADS
1100                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1101 #else
1102                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1103 #endif
1104                     goto do_vivify_rv2xv_elem;
1105
1106                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1107                     is_hash = TRUE;
1108                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1109                     pad_free((++items)->pad_offset);
1110                     goto do_vivify_rv2xv_elem;
1111
1112                 case MDEREF_HV_pop_rv2hv_helem:
1113                 case MDEREF_HV_vivify_rv2hv_helem:
1114                     is_hash = TRUE;
1115                 do_vivify_rv2xv_elem:
1116                 case MDEREF_AV_pop_rv2av_aelem:
1117                 case MDEREF_AV_vivify_rv2av_aelem:
1118                 do_elem:
1119                     switch (actions & MDEREF_INDEX_MASK) {
1120                     case MDEREF_INDEX_none:
1121                         last = 1;
1122                         break;
1123                     case MDEREF_INDEX_const:
1124                         if (is_hash) {
1125 #ifdef USE_ITHREADS
1126                             /* see RT #15654 */
1127                             pad_swipe((++items)->pad_offset, 1);
1128 #else
1129                             SvREFCNT_dec((++items)->sv);
1130 #endif
1131                         }
1132                         else
1133                             items++;
1134                         break;
1135                     case MDEREF_INDEX_padsv:
1136                         pad_free((++items)->pad_offset);
1137                         break;
1138                     case MDEREF_INDEX_gvsv:
1139 #ifdef USE_ITHREADS
1140                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1141 #else
1142                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1143 #endif
1144                         break;
1145                     }
1146
1147                     if (actions & MDEREF_FLAG_last)
1148                         last = 1;
1149                     is_hash = FALSE;
1150
1151                     break;
1152
1153                 default:
1154                     assert(0);
1155                     last = 1;
1156                     break;
1157
1158                 } /* switch */
1159
1160                 actions >>= MDEREF_SHIFT;
1161             } /* while */
1162
1163             /* start of malloc is at op_aux[-1], where the length is
1164              * stored */
1165             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1166         }
1167         break;
1168     }
1169
1170     if (o->op_targ > 0) {
1171         pad_free(o->op_targ);
1172         o->op_targ = 0;
1173     }
1174 }
1175
1176 STATIC void
1177 S_cop_free(pTHX_ COP* cop)
1178 {
1179     PERL_ARGS_ASSERT_COP_FREE;
1180
1181     CopFILE_free(cop);
1182     if (! specialWARN(cop->cop_warnings))
1183         PerlMemShared_free(cop->cop_warnings);
1184     cophh_free(CopHINTHASH_get(cop));
1185     if (PL_curcop == cop)
1186        PL_curcop = NULL;
1187 }
1188
1189 STATIC void
1190 S_forget_pmop(pTHX_ PMOP *const o
1191               )
1192 {
1193     HV * const pmstash = PmopSTASH(o);
1194
1195     PERL_ARGS_ASSERT_FORGET_PMOP;
1196
1197     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1198         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1199         if (mg) {
1200             PMOP **const array = (PMOP**) mg->mg_ptr;
1201             U32 count = mg->mg_len / sizeof(PMOP**);
1202             U32 i = count;
1203
1204             while (i--) {
1205                 if (array[i] == o) {
1206                     /* Found it. Move the entry at the end to overwrite it.  */
1207                     array[i] = array[--count];
1208                     mg->mg_len = count * sizeof(PMOP**);
1209                     /* Could realloc smaller at this point always, but probably
1210                        not worth it. Probably worth free()ing if we're the
1211                        last.  */
1212                     if(!count) {
1213                         Safefree(mg->mg_ptr);
1214                         mg->mg_ptr = NULL;
1215                     }
1216                     break;
1217                 }
1218             }
1219         }
1220     }
1221     if (PL_curpm == o) 
1222         PL_curpm = NULL;
1223 }
1224
1225 STATIC void
1226 S_find_and_forget_pmops(pTHX_ OP *o)
1227 {
1228     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1229
1230     if (o->op_flags & OPf_KIDS) {
1231         OP *kid = cUNOPo->op_first;
1232         while (kid) {
1233             switch (kid->op_type) {
1234             case OP_SUBST:
1235             case OP_SPLIT:
1236             case OP_MATCH:
1237             case OP_QR:
1238                 forget_pmop((PMOP*)kid);
1239             }
1240             find_and_forget_pmops(kid);
1241             kid = OpSIBLING(kid);
1242         }
1243     }
1244 }
1245
1246 /*
1247 =for apidoc Am|void|op_null|OP *o
1248
1249 Neutralizes an op when it is no longer needed, but is still linked to from
1250 other ops.
1251
1252 =cut
1253 */
1254
1255 void
1256 Perl_op_null(pTHX_ OP *o)
1257 {
1258     dVAR;
1259
1260     PERL_ARGS_ASSERT_OP_NULL;
1261
1262     if (o->op_type == OP_NULL)
1263         return;
1264     op_clear(o);
1265     o->op_targ = o->op_type;
1266     OpTYPE_set(o, OP_NULL);
1267 }
1268
1269 void
1270 Perl_op_refcnt_lock(pTHX)
1271   PERL_TSA_ACQUIRE(PL_op_mutex)
1272 {
1273 #ifdef USE_ITHREADS
1274     dVAR;
1275 #endif
1276     PERL_UNUSED_CONTEXT;
1277     OP_REFCNT_LOCK;
1278 }
1279
1280 void
1281 Perl_op_refcnt_unlock(pTHX)
1282   PERL_TSA_RELEASE(PL_op_mutex)
1283 {
1284 #ifdef USE_ITHREADS
1285     dVAR;
1286 #endif
1287     PERL_UNUSED_CONTEXT;
1288     OP_REFCNT_UNLOCK;
1289 }
1290
1291
1292 /*
1293 =for apidoc op_sibling_splice
1294
1295 A general function for editing the structure of an existing chain of
1296 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1297 you to delete zero or more sequential nodes, replacing them with zero or
1298 more different nodes.  Performs the necessary op_first/op_last
1299 housekeeping on the parent node and op_sibling manipulation on the
1300 children.  The last deleted node will be marked as as the last node by
1301 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1302
1303 Note that op_next is not manipulated, and nodes are not freed; that is the
1304 responsibility of the caller.  It also won't create a new list op for an
1305 empty list etc; use higher-level functions like op_append_elem() for that.
1306
1307 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1308 the splicing doesn't affect the first or last op in the chain.
1309
1310 C<start> is the node preceding the first node to be spliced.  Node(s)
1311 following it will be deleted, and ops will be inserted after it.  If it is
1312 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1313 beginning.
1314
1315 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1316 If -1 or greater than or equal to the number of remaining kids, all
1317 remaining kids are deleted.
1318
1319 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1320 If C<NULL>, no nodes are inserted.
1321
1322 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1323 deleted.
1324
1325 For example:
1326
1327     action                    before      after         returns
1328     ------                    -----       -----         -------
1329
1330                               P           P
1331     splice(P, A, 2, X-Y-Z)    |           |             B-C
1332                               A-B-C-D     A-X-Y-Z-D
1333
1334                               P           P
1335     splice(P, NULL, 1, X-Y)   |           |             A
1336                               A-B-C-D     X-Y-B-C-D
1337
1338                               P           P
1339     splice(P, NULL, 3, NULL)  |           |             A-B-C
1340                               A-B-C-D     D
1341
1342                               P           P
1343     splice(P, B, 0, X-Y)      |           |             NULL
1344                               A-B-C-D     A-B-X-Y-C-D
1345
1346
1347 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1348 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1349
1350 =cut
1351 */
1352
1353 OP *
1354 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1355 {
1356     OP *first;
1357     OP *rest;
1358     OP *last_del = NULL;
1359     OP *last_ins = NULL;
1360
1361     if (start)
1362         first = OpSIBLING(start);
1363     else if (!parent)
1364         goto no_parent;
1365     else
1366         first = cLISTOPx(parent)->op_first;
1367
1368     assert(del_count >= -1);
1369
1370     if (del_count && first) {
1371         last_del = first;
1372         while (--del_count && OpHAS_SIBLING(last_del))
1373             last_del = OpSIBLING(last_del);
1374         rest = OpSIBLING(last_del);
1375         OpLASTSIB_set(last_del, NULL);
1376     }
1377     else
1378         rest = first;
1379
1380     if (insert) {
1381         last_ins = insert;
1382         while (OpHAS_SIBLING(last_ins))
1383             last_ins = OpSIBLING(last_ins);
1384         OpMAYBESIB_set(last_ins, rest, NULL);
1385     }
1386     else
1387         insert = rest;
1388
1389     if (start) {
1390         OpMAYBESIB_set(start, insert, NULL);
1391     }
1392     else {
1393         if (!parent)
1394             goto no_parent;
1395         cLISTOPx(parent)->op_first = insert;
1396         if (insert)
1397             parent->op_flags |= OPf_KIDS;
1398         else
1399             parent->op_flags &= ~OPf_KIDS;
1400     }
1401
1402     if (!rest) {
1403         /* update op_last etc */
1404         U32 type;
1405         OP *lastop;
1406
1407         if (!parent)
1408             goto no_parent;
1409
1410         /* ought to use OP_CLASS(parent) here, but that can't handle
1411          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1412          * either */
1413         type = parent->op_type;
1414         if (type == OP_CUSTOM) {
1415             dTHX;
1416             type = XopENTRYCUSTOM(parent, xop_class);
1417         }
1418         else {
1419             if (type == OP_NULL)
1420                 type = parent->op_targ;
1421             type = PL_opargs[type] & OA_CLASS_MASK;
1422         }
1423
1424         lastop = last_ins ? last_ins : start ? start : NULL;
1425         if (   type == OA_BINOP
1426             || type == OA_LISTOP
1427             || type == OA_PMOP
1428             || type == OA_LOOP
1429         )
1430             cLISTOPx(parent)->op_last = lastop;
1431
1432         if (lastop)
1433             OpLASTSIB_set(lastop, parent);
1434     }
1435     return last_del ? first : NULL;
1436
1437   no_parent:
1438     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1439 }
1440
1441
1442 #ifdef PERL_OP_PARENT
1443
1444 /*
1445 =for apidoc op_parent
1446
1447 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1448 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1449
1450 =cut
1451 */
1452
1453 OP *
1454 Perl_op_parent(OP *o)
1455 {
1456     PERL_ARGS_ASSERT_OP_PARENT;
1457     while (OpHAS_SIBLING(o))
1458         o = OpSIBLING(o);
1459     return o->op_sibparent;
1460 }
1461
1462 #endif
1463
1464
1465 /* replace the sibling following start with a new UNOP, which becomes
1466  * the parent of the original sibling; e.g.
1467  *
1468  *  op_sibling_newUNOP(P, A, unop-args...)
1469  *
1470  *  P              P
1471  *  |      becomes |
1472  *  A-B-C          A-U-C
1473  *                   |
1474  *                   B
1475  *
1476  * where U is the new UNOP.
1477  *
1478  * parent and start args are the same as for op_sibling_splice();
1479  * type and flags args are as newUNOP().
1480  *
1481  * Returns the new UNOP.
1482  */
1483
1484 STATIC OP *
1485 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1486 {
1487     OP *kid, *newop;
1488
1489     kid = op_sibling_splice(parent, start, 1, NULL);
1490     newop = newUNOP(type, flags, kid);
1491     op_sibling_splice(parent, start, 0, newop);
1492     return newop;
1493 }
1494
1495
1496 /* lowest-level newLOGOP-style function - just allocates and populates
1497  * the struct. Higher-level stuff should be done by S_new_logop() /
1498  * newLOGOP(). This function exists mainly to avoid op_first assignment
1499  * being spread throughout this file.
1500  */
1501
1502 LOGOP *
1503 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1504 {
1505     dVAR;
1506     LOGOP *logop;
1507     OP *kid = first;
1508     NewOp(1101, logop, 1, LOGOP);
1509     OpTYPE_set(logop, type);
1510     logop->op_first = first;
1511     logop->op_other = other;
1512     logop->op_flags = OPf_KIDS;
1513     while (kid && OpHAS_SIBLING(kid))
1514         kid = OpSIBLING(kid);
1515     if (kid)
1516         OpLASTSIB_set(kid, (OP*)logop);
1517     return logop;
1518 }
1519
1520
1521 /* Contextualizers */
1522
1523 /*
1524 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1525
1526 Applies a syntactic context to an op tree representing an expression.
1527 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1528 or C<G_VOID> to specify the context to apply.  The modified op tree
1529 is returned.
1530
1531 =cut
1532 */
1533
1534 OP *
1535 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1536 {
1537     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1538     switch (context) {
1539         case G_SCALAR: return scalar(o);
1540         case G_ARRAY:  return list(o);
1541         case G_VOID:   return scalarvoid(o);
1542         default:
1543             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1544                        (long) context);
1545     }
1546 }
1547
1548 /*
1549
1550 =for apidoc Am|OP*|op_linklist|OP *o
1551 This function is the implementation of the L</LINKLIST> macro.  It should
1552 not be called directly.
1553
1554 =cut
1555 */
1556
1557 OP *
1558 Perl_op_linklist(pTHX_ OP *o)
1559 {
1560     OP *first;
1561
1562     PERL_ARGS_ASSERT_OP_LINKLIST;
1563
1564     if (o->op_next)
1565         return o->op_next;
1566
1567     /* establish postfix order */
1568     first = cUNOPo->op_first;
1569     if (first) {
1570         OP *kid;
1571         o->op_next = LINKLIST(first);
1572         kid = first;
1573         for (;;) {
1574             OP *sibl = OpSIBLING(kid);
1575             if (sibl) {
1576                 kid->op_next = LINKLIST(sibl);
1577                 kid = sibl;
1578             } else {
1579                 kid->op_next = o;
1580                 break;
1581             }
1582         }
1583     }
1584     else
1585         o->op_next = o;
1586
1587     return o->op_next;
1588 }
1589
1590 static OP *
1591 S_scalarkids(pTHX_ OP *o)
1592 {
1593     if (o && o->op_flags & OPf_KIDS) {
1594         OP *kid;
1595         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1596             scalar(kid);
1597     }
1598     return o;
1599 }
1600
1601 STATIC OP *
1602 S_scalarboolean(pTHX_ OP *o)
1603 {
1604     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1605
1606     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1607          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1608         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1609          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1610          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1611         if (ckWARN(WARN_SYNTAX)) {
1612             const line_t oldline = CopLINE(PL_curcop);
1613
1614             if (PL_parser && PL_parser->copline != NOLINE) {
1615                 /* This ensures that warnings are reported at the first line
1616                    of the conditional, not the last.  */
1617                 CopLINE_set(PL_curcop, PL_parser->copline);
1618             }
1619             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1620             CopLINE_set(PL_curcop, oldline);
1621         }
1622     }
1623     return scalar(o);
1624 }
1625
1626 static SV *
1627 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1628 {
1629     assert(o);
1630     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1631            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1632     {
1633         const char funny  = o->op_type == OP_PADAV
1634                          || o->op_type == OP_RV2AV ? '@' : '%';
1635         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1636             GV *gv;
1637             if (cUNOPo->op_first->op_type != OP_GV
1638              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1639                 return NULL;
1640             return varname(gv, funny, 0, NULL, 0, subscript_type);
1641         }
1642         return
1643             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1644     }
1645 }
1646
1647 static SV *
1648 S_op_varname(pTHX_ const OP *o)
1649 {
1650     return S_op_varname_subscript(aTHX_ o, 1);
1651 }
1652
1653 static void
1654 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1655 { /* or not so pretty :-) */
1656     if (o->op_type == OP_CONST) {
1657         *retsv = cSVOPo_sv;
1658         if (SvPOK(*retsv)) {
1659             SV *sv = *retsv;
1660             *retsv = sv_newmortal();
1661             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1662                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1663         }
1664         else if (!SvOK(*retsv))
1665             *retpv = "undef";
1666     }
1667     else *retpv = "...";
1668 }
1669
1670 static void
1671 S_scalar_slice_warning(pTHX_ const OP *o)
1672 {
1673     OP *kid;
1674     const char lbrack =
1675         o->op_type == OP_HSLICE ? '{' : '[';
1676     const char rbrack =
1677         o->op_type == OP_HSLICE ? '}' : ']';
1678     SV *name;
1679     SV *keysv = NULL; /* just to silence compiler warnings */
1680     const char *key = NULL;
1681
1682     if (!(o->op_private & OPpSLICEWARNING))
1683         return;
1684     if (PL_parser && PL_parser->error_count)
1685         /* This warning can be nonsensical when there is a syntax error. */
1686         return;
1687
1688     kid = cLISTOPo->op_first;
1689     kid = OpSIBLING(kid); /* get past pushmark */
1690     /* weed out false positives: any ops that can return lists */
1691     switch (kid->op_type) {
1692     case OP_BACKTICK:
1693     case OP_GLOB:
1694     case OP_READLINE:
1695     case OP_MATCH:
1696     case OP_RV2AV:
1697     case OP_EACH:
1698     case OP_VALUES:
1699     case OP_KEYS:
1700     case OP_SPLIT:
1701     case OP_LIST:
1702     case OP_SORT:
1703     case OP_REVERSE:
1704     case OP_ENTERSUB:
1705     case OP_CALLER:
1706     case OP_LSTAT:
1707     case OP_STAT:
1708     case OP_READDIR:
1709     case OP_SYSTEM:
1710     case OP_TMS:
1711     case OP_LOCALTIME:
1712     case OP_GMTIME:
1713     case OP_ENTEREVAL:
1714         return;
1715     }
1716
1717     /* Don't warn if we have a nulled list either. */
1718     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1719         return;
1720
1721     assert(OpSIBLING(kid));
1722     name = S_op_varname(aTHX_ OpSIBLING(kid));
1723     if (!name) /* XS module fiddling with the op tree */
1724         return;
1725     S_op_pretty(aTHX_ kid, &keysv, &key);
1726     assert(SvPOK(name));
1727     sv_chop(name,SvPVX(name)+1);
1728     if (key)
1729        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1730         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1731                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1732                    "%c%s%c",
1733                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1734                     lbrack, key, rbrack);
1735     else
1736        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1737         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1738                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1739                     SVf"%c%"SVf"%c",
1740                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1741                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1742 }
1743
1744 OP *
1745 Perl_scalar(pTHX_ OP *o)
1746 {
1747     OP *kid;
1748
1749     /* assumes no premature commitment */
1750     if (!o || (PL_parser && PL_parser->error_count)
1751          || (o->op_flags & OPf_WANT)
1752          || o->op_type == OP_RETURN)
1753     {
1754         return o;
1755     }
1756
1757     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1758
1759     switch (o->op_type) {
1760     case OP_REPEAT:
1761         scalar(cBINOPo->op_first);
1762         if (o->op_private & OPpREPEAT_DOLIST) {
1763             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1764             assert(kid->op_type == OP_PUSHMARK);
1765             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1766                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1767                 o->op_private &=~ OPpREPEAT_DOLIST;
1768             }
1769         }
1770         break;
1771     case OP_OR:
1772     case OP_AND:
1773     case OP_COND_EXPR:
1774         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1775             scalar(kid);
1776         break;
1777         /* FALLTHROUGH */
1778     case OP_SPLIT:
1779     case OP_MATCH:
1780     case OP_QR:
1781     case OP_SUBST:
1782     case OP_NULL:
1783     default:
1784         if (o->op_flags & OPf_KIDS) {
1785             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1786                 scalar(kid);
1787         }
1788         break;
1789     case OP_LEAVE:
1790     case OP_LEAVETRY:
1791         kid = cLISTOPo->op_first;
1792         scalar(kid);
1793         kid = OpSIBLING(kid);
1794     do_kids:
1795         while (kid) {
1796             OP *sib = OpSIBLING(kid);
1797             if (sib && kid->op_type != OP_LEAVEWHEN
1798              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1799                 || (  sib->op_targ != OP_NEXTSTATE
1800                    && sib->op_targ != OP_DBSTATE  )))
1801                 scalarvoid(kid);
1802             else
1803                 scalar(kid);
1804             kid = sib;
1805         }
1806         PL_curcop = &PL_compiling;
1807         break;
1808     case OP_SCOPE:
1809     case OP_LINESEQ:
1810     case OP_LIST:
1811         kid = cLISTOPo->op_first;
1812         goto do_kids;
1813     case OP_SORT:
1814         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1815         break;
1816     case OP_KVHSLICE:
1817     case OP_KVASLICE:
1818     {
1819         /* Warn about scalar context */
1820         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1821         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1822         SV *name;
1823         SV *keysv;
1824         const char *key = NULL;
1825
1826         /* This warning can be nonsensical when there is a syntax error. */
1827         if (PL_parser && PL_parser->error_count)
1828             break;
1829
1830         if (!ckWARN(WARN_SYNTAX)) break;
1831
1832         kid = cLISTOPo->op_first;
1833         kid = OpSIBLING(kid); /* get past pushmark */
1834         assert(OpSIBLING(kid));
1835         name = S_op_varname(aTHX_ OpSIBLING(kid));
1836         if (!name) /* XS module fiddling with the op tree */
1837             break;
1838         S_op_pretty(aTHX_ kid, &keysv, &key);
1839         assert(SvPOK(name));
1840         sv_chop(name,SvPVX(name)+1);
1841         if (key)
1842   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1843             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1844                        "%%%"SVf"%c%s%c in scalar context better written "
1845                        "as $%"SVf"%c%s%c",
1846                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1847                         lbrack, key, rbrack);
1848         else
1849   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1850             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1851                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1852                        "written as $%"SVf"%c%"SVf"%c",
1853                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1854                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1855     }
1856     }
1857     return o;
1858 }
1859
1860 OP *
1861 Perl_scalarvoid(pTHX_ OP *arg)
1862 {
1863     dVAR;
1864     OP *kid;
1865     SV* sv;
1866     U8 want;
1867     SSize_t defer_stack_alloc = 0;
1868     SSize_t defer_ix = -1;
1869     OP **defer_stack = NULL;
1870     OP *o = arg;
1871
1872     PERL_ARGS_ASSERT_SCALARVOID;
1873
1874     do {
1875         SV *useless_sv = NULL;
1876         const char* useless = NULL;
1877
1878         if (o->op_type == OP_NEXTSTATE
1879             || o->op_type == OP_DBSTATE
1880             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1881                                           || o->op_targ == OP_DBSTATE)))
1882             PL_curcop = (COP*)o;                /* for warning below */
1883
1884         /* assumes no premature commitment */
1885         want = o->op_flags & OPf_WANT;
1886         if ((want && want != OPf_WANT_SCALAR)
1887             || (PL_parser && PL_parser->error_count)
1888             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1889         {
1890             continue;
1891         }
1892
1893         if ((o->op_private & OPpTARGET_MY)
1894             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1895         {
1896             /* newASSIGNOP has already applied scalar context, which we
1897                leave, as if this op is inside SASSIGN.  */
1898             continue;
1899         }
1900
1901         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1902
1903         switch (o->op_type) {
1904         default:
1905             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1906                 break;
1907             /* FALLTHROUGH */
1908         case OP_REPEAT:
1909             if (o->op_flags & OPf_STACKED)
1910                 break;
1911             if (o->op_type == OP_REPEAT)
1912                 scalar(cBINOPo->op_first);
1913             goto func_ops;
1914         case OP_SUBSTR:
1915             if (o->op_private == 4)
1916                 break;
1917             /* FALLTHROUGH */
1918         case OP_WANTARRAY:
1919         case OP_GV:
1920         case OP_SMARTMATCH:
1921         case OP_AV2ARYLEN:
1922         case OP_REF:
1923         case OP_REFGEN:
1924         case OP_SREFGEN:
1925         case OP_DEFINED:
1926         case OP_HEX:
1927         case OP_OCT:
1928         case OP_LENGTH:
1929         case OP_VEC:
1930         case OP_INDEX:
1931         case OP_RINDEX:
1932         case OP_SPRINTF:
1933         case OP_KVASLICE:
1934         case OP_KVHSLICE:
1935         case OP_UNPACK:
1936         case OP_PACK:
1937         case OP_JOIN:
1938         case OP_LSLICE:
1939         case OP_ANONLIST:
1940         case OP_ANONHASH:
1941         case OP_SORT:
1942         case OP_REVERSE:
1943         case OP_RANGE:
1944         case OP_FLIP:
1945         case OP_FLOP:
1946         case OP_CALLER:
1947         case OP_FILENO:
1948         case OP_EOF:
1949         case OP_TELL:
1950         case OP_GETSOCKNAME:
1951         case OP_GETPEERNAME:
1952         case OP_READLINK:
1953         case OP_TELLDIR:
1954         case OP_GETPPID:
1955         case OP_GETPGRP:
1956         case OP_GETPRIORITY:
1957         case OP_TIME:
1958         case OP_TMS:
1959         case OP_LOCALTIME:
1960         case OP_GMTIME:
1961         case OP_GHBYNAME:
1962         case OP_GHBYADDR:
1963         case OP_GHOSTENT:
1964         case OP_GNBYNAME:
1965         case OP_GNBYADDR:
1966         case OP_GNETENT:
1967         case OP_GPBYNAME:
1968         case OP_GPBYNUMBER:
1969         case OP_GPROTOENT:
1970         case OP_GSBYNAME:
1971         case OP_GSBYPORT:
1972         case OP_GSERVENT:
1973         case OP_GPWNAM:
1974         case OP_GPWUID:
1975         case OP_GGRNAM:
1976         case OP_GGRGID:
1977         case OP_GETLOGIN:
1978         case OP_PROTOTYPE:
1979         case OP_RUNCV:
1980         func_ops:
1981             useless = OP_DESC(o);
1982             break;
1983
1984         case OP_GVSV:
1985         case OP_PADSV:
1986         case OP_PADAV:
1987         case OP_PADHV:
1988         case OP_PADANY:
1989         case OP_AELEM:
1990         case OP_AELEMFAST:
1991         case OP_AELEMFAST_LEX:
1992         case OP_ASLICE:
1993         case OP_HELEM:
1994         case OP_HSLICE:
1995             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1996                 /* Otherwise it's "Useless use of grep iterator" */
1997                 useless = OP_DESC(o);
1998             break;
1999
2000         case OP_SPLIT:
2001             if (!(o->op_private & OPpSPLIT_ASSIGN))
2002                 useless = OP_DESC(o);
2003             break;
2004
2005         case OP_NOT:
2006             kid = cUNOPo->op_first;
2007             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2008                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2009                 goto func_ops;
2010             }
2011             useless = "negative pattern binding (!~)";
2012             break;
2013
2014         case OP_SUBST:
2015             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2016                 useless = "non-destructive substitution (s///r)";
2017             break;
2018
2019         case OP_TRANSR:
2020             useless = "non-destructive transliteration (tr///r)";
2021             break;
2022
2023         case OP_RV2GV:
2024         case OP_RV2SV:
2025         case OP_RV2AV:
2026         case OP_RV2HV:
2027             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2028                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2029                 useless = "a variable";
2030             break;
2031
2032         case OP_CONST:
2033             sv = cSVOPo_sv;
2034             if (cSVOPo->op_private & OPpCONST_STRICT)
2035                 no_bareword_allowed(o);
2036             else {
2037                 if (ckWARN(WARN_VOID)) {
2038                     NV nv;
2039                     /* don't warn on optimised away booleans, eg
2040                      * use constant Foo, 5; Foo || print; */
2041                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2042                         useless = NULL;
2043                     /* the constants 0 and 1 are permitted as they are
2044                        conventionally used as dummies in constructs like
2045                        1 while some_condition_with_side_effects;  */
2046                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2047                         useless = NULL;
2048                     else if (SvPOK(sv)) {
2049                         SV * const dsv = newSVpvs("");
2050                         useless_sv
2051                             = Perl_newSVpvf(aTHX_
2052                                             "a constant (%s)",
2053                                             pv_pretty(dsv, SvPVX_const(sv),
2054                                                       SvCUR(sv), 32, NULL, NULL,
2055                                                       PERL_PV_PRETTY_DUMP
2056                                                       | PERL_PV_ESCAPE_NOCLEAR
2057                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2058                         SvREFCNT_dec_NN(dsv);
2059                     }
2060                     else if (SvOK(sv)) {
2061                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2062                     }
2063                     else
2064                         useless = "a constant (undef)";
2065                 }
2066             }
2067             op_null(o);         /* don't execute or even remember it */
2068             break;
2069
2070         case OP_POSTINC:
2071             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2072             break;
2073
2074         case OP_POSTDEC:
2075             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2076             break;
2077
2078         case OP_I_POSTINC:
2079             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2080             break;
2081
2082         case OP_I_POSTDEC:
2083             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2084             break;
2085
2086         case OP_SASSIGN: {
2087             OP *rv2gv;
2088             UNOP *refgen, *rv2cv;
2089             LISTOP *exlist;
2090
2091             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2092                 break;
2093
2094             rv2gv = ((BINOP *)o)->op_last;
2095             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2096                 break;
2097
2098             refgen = (UNOP *)((BINOP *)o)->op_first;
2099
2100             if (!refgen || (refgen->op_type != OP_REFGEN
2101                             && refgen->op_type != OP_SREFGEN))
2102                 break;
2103
2104             exlist = (LISTOP *)refgen->op_first;
2105             if (!exlist || exlist->op_type != OP_NULL
2106                 || exlist->op_targ != OP_LIST)
2107                 break;
2108
2109             if (exlist->op_first->op_type != OP_PUSHMARK
2110                 && exlist->op_first != exlist->op_last)
2111                 break;
2112
2113             rv2cv = (UNOP*)exlist->op_last;
2114
2115             if (rv2cv->op_type != OP_RV2CV)
2116                 break;
2117
2118             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2119             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2120             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2121
2122             o->op_private |= OPpASSIGN_CV_TO_GV;
2123             rv2gv->op_private |= OPpDONT_INIT_GV;
2124             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2125
2126             break;
2127         }
2128
2129         case OP_AASSIGN: {
2130             inplace_aassign(o);
2131             break;
2132         }
2133
2134         case OP_OR:
2135         case OP_AND:
2136             kid = cLOGOPo->op_first;
2137             if (kid->op_type == OP_NOT
2138                 && (kid->op_flags & OPf_KIDS)) {
2139                 if (o->op_type == OP_AND) {
2140                     OpTYPE_set(o, OP_OR);
2141                 } else {
2142                     OpTYPE_set(o, OP_AND);
2143                 }
2144                 op_null(kid);
2145             }
2146             /* FALLTHROUGH */
2147
2148         case OP_DOR:
2149         case OP_COND_EXPR:
2150         case OP_ENTERGIVEN:
2151         case OP_ENTERWHEN:
2152             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2153                 if (!(kid->op_flags & OPf_KIDS))
2154                     scalarvoid(kid);
2155                 else
2156                     DEFER_OP(kid);
2157         break;
2158
2159         case OP_NULL:
2160             if (o->op_flags & OPf_STACKED)
2161                 break;
2162             /* FALLTHROUGH */
2163         case OP_NEXTSTATE:
2164         case OP_DBSTATE:
2165         case OP_ENTERTRY:
2166         case OP_ENTER:
2167             if (!(o->op_flags & OPf_KIDS))
2168                 break;
2169             /* FALLTHROUGH */
2170         case OP_SCOPE:
2171         case OP_LEAVE:
2172         case OP_LEAVETRY:
2173         case OP_LEAVELOOP:
2174         case OP_LINESEQ:
2175         case OP_LEAVEGIVEN:
2176         case OP_LEAVEWHEN:
2177         kids:
2178             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2179                 if (!(kid->op_flags & OPf_KIDS))
2180                     scalarvoid(kid);
2181                 else
2182                     DEFER_OP(kid);
2183             break;
2184         case OP_LIST:
2185             /* If the first kid after pushmark is something that the padrange
2186                optimisation would reject, then null the list and the pushmark.
2187             */
2188             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2189                 && (  !(kid = OpSIBLING(kid))
2190                       || (  kid->op_type != OP_PADSV
2191                             && kid->op_type != OP_PADAV
2192                             && kid->op_type != OP_PADHV)
2193                       || kid->op_private & ~OPpLVAL_INTRO
2194                       || !(kid = OpSIBLING(kid))
2195                       || (  kid->op_type != OP_PADSV
2196                             && kid->op_type != OP_PADAV
2197                             && kid->op_type != OP_PADHV)
2198                       || kid->op_private & ~OPpLVAL_INTRO)
2199             ) {
2200                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2201                 op_null(o); /* NULL the list */
2202             }
2203             goto kids;
2204         case OP_ENTEREVAL:
2205             scalarkids(o);
2206             break;
2207         case OP_SCALAR:
2208             scalar(o);
2209             break;
2210         }
2211
2212         if (useless_sv) {
2213             /* mortalise it, in case warnings are fatal.  */
2214             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2215                            "Useless use of %"SVf" in void context",
2216                            SVfARG(sv_2mortal(useless_sv)));
2217         }
2218         else if (useless) {
2219             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2220                            "Useless use of %s in void context",
2221                            useless);
2222         }
2223     } while ( (o = POP_DEFERRED_OP()) );
2224
2225     Safefree(defer_stack);
2226
2227     return arg;
2228 }
2229
2230 static OP *
2231 S_listkids(pTHX_ OP *o)
2232 {
2233     if (o && o->op_flags & OPf_KIDS) {
2234         OP *kid;
2235         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2236             list(kid);
2237     }
2238     return o;
2239 }
2240
2241 OP *
2242 Perl_list(pTHX_ OP *o)
2243 {
2244     OP *kid;
2245
2246     /* assumes no premature commitment */
2247     if (!o || (o->op_flags & OPf_WANT)
2248          || (PL_parser && PL_parser->error_count)
2249          || o->op_type == OP_RETURN)
2250     {
2251         return o;
2252     }
2253
2254     if ((o->op_private & OPpTARGET_MY)
2255         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2256     {
2257         return o;                               /* As if inside SASSIGN */
2258     }
2259
2260     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2261
2262     switch (o->op_type) {
2263     case OP_FLOP:
2264         list(cBINOPo->op_first);
2265         break;
2266     case OP_REPEAT:
2267         if (o->op_private & OPpREPEAT_DOLIST
2268          && !(o->op_flags & OPf_STACKED))
2269         {
2270             list(cBINOPo->op_first);
2271             kid = cBINOPo->op_last;
2272             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2273              && SvIVX(kSVOP_sv) == 1)
2274             {
2275                 op_null(o); /* repeat */
2276                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2277                 /* const (rhs): */
2278                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2279             }
2280         }
2281         break;
2282     case OP_OR:
2283     case OP_AND:
2284     case OP_COND_EXPR:
2285         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2286             list(kid);
2287         break;
2288     default:
2289     case OP_MATCH:
2290     case OP_QR:
2291     case OP_SUBST:
2292     case OP_NULL:
2293         if (!(o->op_flags & OPf_KIDS))
2294             break;
2295         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2296             list(cBINOPo->op_first);
2297             return gen_constant_list(o);
2298         }
2299         listkids(o);
2300         break;
2301     case OP_LIST:
2302         listkids(o);
2303         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2304             op_null(cUNOPo->op_first); /* NULL the pushmark */
2305             op_null(o); /* NULL the list */
2306         }
2307         break;
2308     case OP_LEAVE:
2309     case OP_LEAVETRY:
2310         kid = cLISTOPo->op_first;
2311         list(kid);
2312         kid = OpSIBLING(kid);
2313     do_kids:
2314         while (kid) {
2315             OP *sib = OpSIBLING(kid);
2316             if (sib && kid->op_type != OP_LEAVEWHEN)
2317                 scalarvoid(kid);
2318             else
2319                 list(kid);
2320             kid = sib;
2321         }
2322         PL_curcop = &PL_compiling;
2323         break;
2324     case OP_SCOPE:
2325     case OP_LINESEQ:
2326         kid = cLISTOPo->op_first;
2327         goto do_kids;
2328     }
2329     return o;
2330 }
2331
2332 static OP *
2333 S_scalarseq(pTHX_ OP *o)
2334 {
2335     if (o) {
2336         const OPCODE type = o->op_type;
2337
2338         if (type == OP_LINESEQ || type == OP_SCOPE ||
2339             type == OP_LEAVE || type == OP_LEAVETRY)
2340         {
2341             OP *kid, *sib;
2342             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2343                 if ((sib = OpSIBLING(kid))
2344                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2345                     || (  sib->op_targ != OP_NEXTSTATE
2346                        && sib->op_targ != OP_DBSTATE  )))
2347                 {
2348                     scalarvoid(kid);
2349                 }
2350             }
2351             PL_curcop = &PL_compiling;
2352         }
2353         o->op_flags &= ~OPf_PARENS;
2354         if (PL_hints & HINT_BLOCK_SCOPE)
2355             o->op_flags |= OPf_PARENS;
2356     }
2357     else
2358         o = newOP(OP_STUB, 0);
2359     return o;
2360 }
2361
2362 STATIC OP *
2363 S_modkids(pTHX_ OP *o, I32 type)
2364 {
2365     if (o && o->op_flags & OPf_KIDS) {
2366         OP *kid;
2367         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2368             op_lvalue(kid, type);
2369     }
2370     return o;
2371 }
2372
2373
2374 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2375  * const fields. Also, convert CONST keys to HEK-in-SVs.
2376  * rop is the op that retrieves the hash;
2377  * key_op is the first key
2378  */
2379
2380 STATIC void
2381 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2382 {
2383     PADNAME *lexname;
2384     GV **fields;
2385     bool check_fields;
2386
2387     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2388     if (rop) {
2389         if (rop->op_first->op_type == OP_PADSV)
2390             /* @$hash{qw(keys here)} */
2391             rop = (UNOP*)rop->op_first;
2392         else {
2393             /* @{$hash}{qw(keys here)} */
2394             if (rop->op_first->op_type == OP_SCOPE
2395                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2396                 {
2397                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2398                 }
2399             else
2400                 rop = NULL;
2401         }
2402     }
2403
2404     lexname = NULL; /* just to silence compiler warnings */
2405     fields  = NULL; /* just to silence compiler warnings */
2406
2407     check_fields =
2408             rop
2409          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2410              SvPAD_TYPED(lexname))
2411          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2412          && isGV(*fields) && GvHV(*fields);
2413
2414     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2415         SV **svp, *sv;
2416         if (key_op->op_type != OP_CONST)
2417             continue;
2418         svp = cSVOPx_svp(key_op);
2419
2420         /* make sure it's not a bareword under strict subs */
2421         if (key_op->op_private & OPpCONST_BARE &&
2422             key_op->op_private & OPpCONST_STRICT)
2423         {
2424             no_bareword_allowed((OP*)key_op);
2425         }
2426
2427         /* Make the CONST have a shared SV */
2428         if (   !SvIsCOW_shared_hash(sv = *svp)
2429             && SvTYPE(sv) < SVt_PVMG
2430             && SvOK(sv)
2431             && !SvROK(sv))
2432         {
2433             SSize_t keylen;
2434             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2435             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2436             SvREFCNT_dec_NN(sv);
2437             *svp = nsv;
2438         }
2439
2440         if (   check_fields
2441             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2442         {
2443             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2444                         "in variable %"PNf" of type %"HEKf,
2445                         SVfARG(*svp), PNfARG(lexname),
2446                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2447         }
2448     }
2449 }
2450
2451
2452 /*
2453 =for apidoc finalize_optree
2454
2455 This function finalizes the optree.  Should be called directly after
2456 the complete optree is built.  It does some additional
2457 checking which can't be done in the normal C<ck_>xxx functions and makes
2458 the tree thread-safe.
2459
2460 =cut
2461 */
2462 void
2463 Perl_finalize_optree(pTHX_ OP* o)
2464 {
2465     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2466
2467     ENTER;
2468     SAVEVPTR(PL_curcop);
2469
2470     finalize_op(o);
2471
2472     LEAVE;
2473 }
2474
2475 #ifdef USE_ITHREADS
2476 /* Relocate sv to the pad for thread safety.
2477  * Despite being a "constant", the SV is written to,
2478  * for reference counts, sv_upgrade() etc. */
2479 PERL_STATIC_INLINE void
2480 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2481 {
2482     PADOFFSET ix;
2483     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2484     if (!*svp) return;
2485     ix = pad_alloc(OP_CONST, SVf_READONLY);
2486     SvREFCNT_dec(PAD_SVl(ix));
2487     PAD_SETSV(ix, *svp);
2488     /* XXX I don't know how this isn't readonly already. */
2489     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2490     *svp = NULL;
2491     *targp = ix;
2492 }
2493 #endif
2494
2495
2496 STATIC void
2497 S_finalize_op(pTHX_ OP* o)
2498 {
2499     PERL_ARGS_ASSERT_FINALIZE_OP;
2500
2501     assert(o->op_type != OP_FREED);
2502
2503     switch (o->op_type) {
2504     case OP_NEXTSTATE:
2505     case OP_DBSTATE:
2506         PL_curcop = ((COP*)o);          /* for warnings */
2507         break;
2508     case OP_EXEC:
2509         if (OpHAS_SIBLING(o)) {
2510             OP *sib = OpSIBLING(o);
2511             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2512                 && ckWARN(WARN_EXEC)
2513                 && OpHAS_SIBLING(sib))
2514             {
2515                     const OPCODE type = OpSIBLING(sib)->op_type;
2516                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2517                         const line_t oldline = CopLINE(PL_curcop);
2518                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2519                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2520                             "Statement unlikely to be reached");
2521                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2522                             "\t(Maybe you meant system() when you said exec()?)\n");
2523                         CopLINE_set(PL_curcop, oldline);
2524                     }
2525             }
2526         }
2527         break;
2528
2529     case OP_GV:
2530         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2531             GV * const gv = cGVOPo_gv;
2532             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2533                 /* XXX could check prototype here instead of just carping */
2534                 SV * const sv = sv_newmortal();
2535                 gv_efullname3(sv, gv, NULL);
2536                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2537                     "%"SVf"() called too early to check prototype",
2538                     SVfARG(sv));
2539             }
2540         }
2541         break;
2542
2543     case OP_CONST:
2544         if (cSVOPo->op_private & OPpCONST_STRICT)
2545             no_bareword_allowed(o);
2546         /* FALLTHROUGH */
2547 #ifdef USE_ITHREADS
2548     case OP_HINTSEVAL:
2549         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2550 #endif
2551         break;
2552
2553 #ifdef USE_ITHREADS
2554     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2555     case OP_METHOD_NAMED:
2556     case OP_METHOD_SUPER:
2557     case OP_METHOD_REDIR:
2558     case OP_METHOD_REDIR_SUPER:
2559         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2560         break;
2561 #endif
2562
2563     case OP_HELEM: {
2564         UNOP *rop;
2565         SVOP *key_op;
2566         OP *kid;
2567
2568         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2569             break;
2570
2571         rop = (UNOP*)((BINOP*)o)->op_first;
2572
2573         goto check_keys;
2574
2575     case OP_HSLICE:
2576         S_scalar_slice_warning(aTHX_ o);
2577         /* FALLTHROUGH */
2578
2579     case OP_KVHSLICE:
2580         kid = OpSIBLING(cLISTOPo->op_first);
2581         if (/* I bet there's always a pushmark... */
2582             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2583             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2584         {
2585             break;
2586         }
2587
2588         key_op = (SVOP*)(kid->op_type == OP_CONST
2589                                 ? kid
2590                                 : OpSIBLING(kLISTOP->op_first));
2591
2592         rop = (UNOP*)((LISTOP*)o)->op_last;
2593
2594       check_keys:       
2595         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2596             rop = NULL;
2597         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2598         break;
2599     }
2600     case OP_ASLICE:
2601         S_scalar_slice_warning(aTHX_ o);
2602         break;
2603
2604     case OP_SUBST: {
2605         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2606             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2607         break;
2608     }
2609     default:
2610         break;
2611     }
2612
2613     if (o->op_flags & OPf_KIDS) {
2614         OP *kid;
2615
2616 #ifdef DEBUGGING
2617         /* check that op_last points to the last sibling, and that
2618          * the last op_sibling/op_sibparent field points back to the
2619          * parent, and that the only ops with KIDS are those which are
2620          * entitled to them */
2621         U32 type = o->op_type;
2622         U32 family;
2623         bool has_last;
2624
2625         if (type == OP_NULL) {
2626             type = o->op_targ;
2627             /* ck_glob creates a null UNOP with ex-type GLOB
2628              * (which is a list op. So pretend it wasn't a listop */
2629             if (type == OP_GLOB)
2630                 type = OP_NULL;
2631         }
2632         family = PL_opargs[type] & OA_CLASS_MASK;
2633
2634         has_last = (   family == OA_BINOP
2635                     || family == OA_LISTOP
2636                     || family == OA_PMOP
2637                     || family == OA_LOOP
2638                    );
2639         assert(  has_last /* has op_first and op_last, or ...
2640               ... has (or may have) op_first: */
2641               || family == OA_UNOP
2642               || family == OA_UNOP_AUX
2643               || family == OA_LOGOP
2644               || family == OA_BASEOP_OR_UNOP
2645               || family == OA_FILESTATOP
2646               || family == OA_LOOPEXOP
2647               || family == OA_METHOP
2648               || type == OP_CUSTOM
2649               || type == OP_NULL /* new_logop does this */
2650               );
2651
2652         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2653 #  ifdef PERL_OP_PARENT
2654             if (!OpHAS_SIBLING(kid)) {
2655                 if (has_last)
2656                     assert(kid == cLISTOPo->op_last);
2657                 assert(kid->op_sibparent == o);
2658             }
2659 #  else
2660             if (has_last && !OpHAS_SIBLING(kid))
2661                 assert(kid == cLISTOPo->op_last);
2662 #  endif
2663         }
2664 #endif
2665
2666         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2667             finalize_op(kid);
2668     }
2669 }
2670
2671 /*
2672 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2673
2674 Propagate lvalue ("modifiable") context to an op and its children.
2675 C<type> represents the context type, roughly based on the type of op that
2676 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2677 because it has no op type of its own (it is signalled by a flag on
2678 the lvalue op).
2679
2680 This function detects things that can't be modified, such as C<$x+1>, and
2681 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2682 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2683
2684 It also flags things that need to behave specially in an lvalue context,
2685 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2686
2687 =cut
2688 */
2689
2690 static void
2691 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2692 {
2693     CV *cv = PL_compcv;
2694     PadnameLVALUE_on(pn);
2695     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2696         cv = CvOUTSIDE(cv);
2697         /* RT #127786: cv can be NULL due to an eval within the DB package
2698          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2699          * unless they contain an eval, but calling eval within DB
2700          * pretends the eval was done in the caller's scope.
2701          */
2702         if (!cv)
2703             break;
2704         assert(CvPADLIST(cv));
2705         pn =
2706            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2707         assert(PadnameLEN(pn));
2708         PadnameLVALUE_on(pn);
2709     }
2710 }
2711
2712 static bool
2713 S_vivifies(const OPCODE type)
2714 {
2715     switch(type) {
2716     case OP_RV2AV:     case   OP_ASLICE:
2717     case OP_RV2HV:     case OP_KVASLICE:
2718     case OP_RV2SV:     case   OP_HSLICE:
2719     case OP_AELEMFAST: case OP_KVHSLICE:
2720     case OP_HELEM:
2721     case OP_AELEM:
2722         return 1;
2723     }
2724     return 0;
2725 }
2726
2727 static void
2728 S_lvref(pTHX_ OP *o, I32 type)
2729 {
2730     dVAR;
2731     OP *kid;
2732     switch (o->op_type) {
2733     case OP_COND_EXPR:
2734         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2735              kid = OpSIBLING(kid))
2736             S_lvref(aTHX_ kid, type);
2737         /* FALLTHROUGH */
2738     case OP_PUSHMARK:
2739         return;
2740     case OP_RV2AV:
2741         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2742         o->op_flags |= OPf_STACKED;
2743         if (o->op_flags & OPf_PARENS) {
2744             if (o->op_private & OPpLVAL_INTRO) {
2745                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2746                       "localized parenthesized array in list assignment"));
2747                 return;
2748             }
2749           slurpy:
2750             OpTYPE_set(o, OP_LVAVREF);
2751             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2752             o->op_flags |= OPf_MOD|OPf_REF;
2753             return;
2754         }
2755         o->op_private |= OPpLVREF_AV;
2756         goto checkgv;
2757     case OP_RV2CV:
2758         kid = cUNOPo->op_first;
2759         if (kid->op_type == OP_NULL)
2760             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2761                 ->op_first;
2762         o->op_private = OPpLVREF_CV;
2763         if (kid->op_type == OP_GV)
2764             o->op_flags |= OPf_STACKED;
2765         else if (kid->op_type == OP_PADCV) {
2766             o->op_targ = kid->op_targ;
2767             kid->op_targ = 0;
2768             op_free(cUNOPo->op_first);
2769             cUNOPo->op_first = NULL;
2770             o->op_flags &=~ OPf_KIDS;
2771         }
2772         else goto badref;
2773         break;
2774     case OP_RV2HV:
2775         if (o->op_flags & OPf_PARENS) {
2776           parenhash:
2777             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2778                                  "parenthesized hash in list assignment"));
2779                 return;
2780         }
2781         o->op_private |= OPpLVREF_HV;
2782         /* FALLTHROUGH */
2783     case OP_RV2SV:
2784       checkgv:
2785         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2786         o->op_flags |= OPf_STACKED;
2787         break;
2788     case OP_PADHV:
2789         if (o->op_flags & OPf_PARENS) goto parenhash;
2790         o->op_private |= OPpLVREF_HV;
2791         /* FALLTHROUGH */
2792     case OP_PADSV:
2793         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2794         break;
2795     case OP_PADAV:
2796         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2797         if (o->op_flags & OPf_PARENS) goto slurpy;
2798         o->op_private |= OPpLVREF_AV;
2799         break;
2800     case OP_AELEM:
2801     case OP_HELEM:
2802         o->op_private |= OPpLVREF_ELEM;
2803         o->op_flags   |= OPf_STACKED;
2804         break;
2805     case OP_ASLICE:
2806     case OP_HSLICE:
2807         OpTYPE_set(o, OP_LVREFSLICE);
2808         o->op_private &= OPpLVAL_INTRO;
2809         return;
2810     case OP_NULL:
2811         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2812             goto badref;
2813         else if (!(o->op_flags & OPf_KIDS))
2814             return;
2815         if (o->op_targ != OP_LIST) {
2816             S_lvref(aTHX_ cBINOPo->op_first, type);
2817             return;
2818         }
2819         /* FALLTHROUGH */
2820     case OP_LIST:
2821         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2822             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2823             S_lvref(aTHX_ kid, type);
2824         }
2825         return;
2826     case OP_STUB:
2827         if (o->op_flags & OPf_PARENS)
2828             return;
2829         /* FALLTHROUGH */
2830     default:
2831       badref:
2832         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2833         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2834                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2835                       ? "do block"
2836                       : OP_DESC(o),
2837                      PL_op_desc[type]));
2838         return;
2839     }
2840     OpTYPE_set(o, OP_LVREF);
2841     o->op_private &=
2842         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2843     if (type == OP_ENTERLOOP)
2844         o->op_private |= OPpLVREF_ITER;
2845 }
2846
2847 PERL_STATIC_INLINE bool
2848 S_potential_mod_type(I32 type)
2849 {
2850     /* Types that only potentially result in modification.  */
2851     return type == OP_GREPSTART || type == OP_ENTERSUB
2852         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2853 }
2854
2855 OP *
2856 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2857 {
2858     dVAR;
2859     OP *kid;
2860     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2861     int localize = -1;
2862
2863     if (!o || (PL_parser && PL_parser->error_count))
2864         return o;
2865
2866     if ((o->op_private & OPpTARGET_MY)
2867         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2868     {
2869         return o;
2870     }
2871
2872     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2873
2874     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2875
2876     switch (o->op_type) {
2877     case OP_UNDEF:
2878         PL_modcount++;
2879         return o;
2880     case OP_STUB:
2881         if ((o->op_flags & OPf_PARENS))
2882             break;
2883         goto nomod;
2884     case OP_ENTERSUB:
2885         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2886             !(o->op_flags & OPf_STACKED)) {
2887             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2888             assert(cUNOPo->op_first->op_type == OP_NULL);
2889             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2890             break;
2891         }
2892         else {                          /* lvalue subroutine call */
2893             o->op_private |= OPpLVAL_INTRO;
2894             PL_modcount = RETURN_UNLIMITED_NUMBER;
2895             if (S_potential_mod_type(type)) {
2896                 o->op_private |= OPpENTERSUB_INARGS;
2897                 break;
2898             }
2899             else {                      /* Compile-time error message: */
2900                 OP *kid = cUNOPo->op_first;
2901                 CV *cv;
2902                 GV *gv;
2903                 SV *namesv;
2904
2905                 if (kid->op_type != OP_PUSHMARK) {
2906                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2907                         Perl_croak(aTHX_
2908                                 "panic: unexpected lvalue entersub "
2909                                 "args: type/targ %ld:%"UVuf,
2910                                 (long)kid->op_type, (UV)kid->op_targ);
2911                     kid = kLISTOP->op_first;
2912                 }
2913                 while (OpHAS_SIBLING(kid))
2914                     kid = OpSIBLING(kid);
2915                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2916                     break;      /* Postpone until runtime */
2917                 }
2918
2919                 kid = kUNOP->op_first;
2920                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2921                     kid = kUNOP->op_first;
2922                 if (kid->op_type == OP_NULL)
2923                     Perl_croak(aTHX_
2924                                "Unexpected constant lvalue entersub "
2925                                "entry via type/targ %ld:%"UVuf,
2926                                (long)kid->op_type, (UV)kid->op_targ);
2927                 if (kid->op_type != OP_GV) {
2928                     break;
2929                 }
2930
2931                 gv = kGVOP_gv;
2932                 cv = isGV(gv)
2933                     ? GvCV(gv)
2934                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2935                         ? MUTABLE_CV(SvRV(gv))
2936                         : NULL;
2937                 if (!cv)
2938                     break;
2939                 if (CvLVALUE(cv))
2940                     break;
2941                 if (flags & OP_LVALUE_NO_CROAK)
2942                     return NULL;
2943
2944                 namesv = cv_name(cv, NULL, 0);
2945                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2946                                      "subroutine call of &%"SVf" in %s",
2947                                      SVfARG(namesv), PL_op_desc[type]),
2948                            SvUTF8(namesv));
2949                 return o;
2950             }
2951         }
2952         /* FALLTHROUGH */
2953     default:
2954       nomod:
2955         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2956         /* grep, foreach, subcalls, refgen */
2957         if (S_potential_mod_type(type))
2958             break;
2959         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2960                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2961                       ? "do block"
2962                       : OP_DESC(o)),
2963                      type ? PL_op_desc[type] : "local"));
2964         return o;
2965
2966     case OP_PREINC:
2967     case OP_PREDEC:
2968     case OP_POW:
2969     case OP_MULTIPLY:
2970     case OP_DIVIDE:
2971     case OP_MODULO:
2972     case OP_ADD:
2973     case OP_SUBTRACT:
2974     case OP_CONCAT:
2975     case OP_LEFT_SHIFT:
2976     case OP_RIGHT_SHIFT:
2977     case OP_BIT_AND:
2978     case OP_BIT_XOR:
2979     case OP_BIT_OR:
2980     case OP_I_MULTIPLY:
2981     case OP_I_DIVIDE:
2982     case OP_I_MODULO:
2983     case OP_I_ADD:
2984     case OP_I_SUBTRACT:
2985         if (!(o->op_flags & OPf_STACKED))
2986             goto nomod;
2987         PL_modcount++;
2988         break;
2989
2990     case OP_REPEAT:
2991         if (o->op_flags & OPf_STACKED) {
2992             PL_modcount++;
2993             break;
2994         }
2995         if (!(o->op_private & OPpREPEAT_DOLIST))
2996             goto nomod;
2997         else {
2998             const I32 mods = PL_modcount;
2999             modkids(cBINOPo->op_first, type);
3000             if (type != OP_AASSIGN)
3001                 goto nomod;
3002             kid = cBINOPo->op_last;
3003             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3004                 const IV iv = SvIV(kSVOP_sv);
3005                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3006                     PL_modcount =
3007                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3008             }
3009             else
3010                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3011         }
3012         break;
3013
3014     case OP_COND_EXPR:
3015         localize = 1;
3016         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3017             op_lvalue(kid, type);
3018         break;
3019
3020     case OP_RV2AV:
3021     case OP_RV2HV:
3022         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3023            PL_modcount = RETURN_UNLIMITED_NUMBER;
3024             return o;           /* Treat \(@foo) like ordinary list. */
3025         }
3026         /* FALLTHROUGH */
3027     case OP_RV2GV:
3028         if (scalar_mod_type(o, type))
3029             goto nomod;
3030         ref(cUNOPo->op_first, o->op_type);
3031         /* FALLTHROUGH */
3032     case OP_ASLICE:
3033     case OP_HSLICE:
3034         localize = 1;
3035         /* FALLTHROUGH */
3036     case OP_AASSIGN:
3037         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3038         if (type == OP_LEAVESUBLV && (
3039                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3040              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3041            ))
3042             o->op_private |= OPpMAYBE_LVSUB;
3043         /* FALLTHROUGH */
3044     case OP_NEXTSTATE:
3045     case OP_DBSTATE:
3046        PL_modcount = RETURN_UNLIMITED_NUMBER;
3047         break;
3048     case OP_KVHSLICE:
3049     case OP_KVASLICE:
3050     case OP_AKEYS:
3051         if (type == OP_LEAVESUBLV)
3052             o->op_private |= OPpMAYBE_LVSUB;
3053         goto nomod;
3054     case OP_AVHVSWITCH:
3055         if (type == OP_LEAVESUBLV
3056          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3057             o->op_private |= OPpMAYBE_LVSUB;
3058         goto nomod;
3059     case OP_AV2ARYLEN:
3060         PL_hints |= HINT_BLOCK_SCOPE;
3061         if (type == OP_LEAVESUBLV)
3062             o->op_private |= OPpMAYBE_LVSUB;
3063         PL_modcount++;
3064         break;
3065     case OP_RV2SV:
3066         ref(cUNOPo->op_first, o->op_type);
3067         localize = 1;
3068         /* FALLTHROUGH */
3069     case OP_GV:
3070         PL_hints |= HINT_BLOCK_SCOPE;
3071         /* FALLTHROUGH */
3072     case OP_SASSIGN:
3073     case OP_ANDASSIGN:
3074     case OP_ORASSIGN:
3075     case OP_DORASSIGN:
3076         PL_modcount++;
3077         break;
3078
3079     case OP_AELEMFAST:
3080     case OP_AELEMFAST_LEX:
3081         localize = -1;
3082         PL_modcount++;
3083         break;
3084
3085     case OP_PADAV:
3086     case OP_PADHV:
3087        PL_modcount = RETURN_UNLIMITED_NUMBER;
3088         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3089             return o;           /* Treat \(@foo) like ordinary list. */
3090         if (scalar_mod_type(o, type))
3091             goto nomod;
3092         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3093           && type == OP_LEAVESUBLV)
3094             o->op_private |= OPpMAYBE_LVSUB;
3095         /* FALLTHROUGH */
3096     case OP_PADSV:
3097         PL_modcount++;
3098         if (!type) /* local() */
3099             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3100                               PNfARG(PAD_COMPNAME(o->op_targ)));
3101         if (!(o->op_private & OPpLVAL_INTRO)
3102          || (  type != OP_SASSIGN && type != OP_AASSIGN
3103             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3104             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3105         break;
3106
3107     case OP_PUSHMARK:
3108         localize = 0;
3109         break;
3110
3111     case OP_KEYS:
3112         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3113             goto nomod;
3114         goto lvalue_func;
3115     case OP_SUBSTR:
3116         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3117             goto nomod;
3118         /* FALLTHROUGH */
3119     case OP_POS:
3120     case OP_VEC:
3121       lvalue_func:
3122         if (type == OP_LEAVESUBLV)
3123             o->op_private |= OPpMAYBE_LVSUB;
3124         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3125             /* substr and vec */
3126             /* If this op is in merely potential (non-fatal) modifiable
3127                context, then apply OP_ENTERSUB context to
3128                the kid op (to avoid croaking).  Other-
3129                wise pass this op’s own type so the correct op is mentioned
3130                in error messages.  */
3131             op_lvalue(OpSIBLING(cBINOPo->op_first),
3132                       S_potential_mod_type(type)
3133                         ? (I32)OP_ENTERSUB
3134                         : o->op_type);
3135         }
3136         break;
3137
3138     case OP_AELEM:
3139     case OP_HELEM:
3140         ref(cBINOPo->op_first, o->op_type);
3141         if (type == OP_ENTERSUB &&
3142              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3143             o->op_private |= OPpLVAL_DEFER;
3144         if (type == OP_LEAVESUBLV)
3145             o->op_private |= OPpMAYBE_LVSUB;
3146         localize = 1;
3147         PL_modcount++;
3148         break;
3149
3150     case OP_LEAVE:
3151     case OP_LEAVELOOP:
3152         o->op_private |= OPpLVALUE;
3153         /* FALLTHROUGH */
3154     case OP_SCOPE:
3155     case OP_ENTER:
3156     case OP_LINESEQ:
3157         localize = 0;
3158         if (o->op_flags & OPf_KIDS)
3159             op_lvalue(cLISTOPo->op_last, type);
3160         break;
3161
3162     case OP_NULL:
3163         localize = 0;
3164         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3165             goto nomod;
3166         else if (!(o->op_flags & OPf_KIDS))
3167             break;
3168         if (o->op_targ != OP_LIST) {
3169             op_lvalue(cBINOPo->op_first, type);
3170             break;
3171         }
3172         /* FALLTHROUGH */
3173     case OP_LIST:
3174         localize = 0;
3175         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3176             /* elements might be in void context because the list is
3177                in scalar context or because they are attribute sub calls */
3178             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3179                 op_lvalue(kid, type);
3180         break;
3181
3182     case OP_COREARGS:
3183         return o;
3184
3185     case OP_AND:
3186     case OP_OR:
3187         if (type == OP_LEAVESUBLV
3188          || !S_vivifies(cLOGOPo->op_first->op_type))
3189             op_lvalue(cLOGOPo->op_first, type);
3190         if (type == OP_LEAVESUBLV
3191          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3192             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3193         goto nomod;
3194
3195     case OP_SREFGEN:
3196         if (type == OP_NULL) { /* local */
3197           local_refgen:
3198             if (!FEATURE_MYREF_IS_ENABLED)
3199                 Perl_croak(aTHX_ "The experimental declared_refs "
3200                                  "feature is not enabled");
3201             Perl_ck_warner_d(aTHX_
3202                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3203                     "Declaring references is experimental");
3204             op_lvalue(cUNOPo->op_first, OP_NULL);
3205             return o;
3206         }
3207         if (type != OP_AASSIGN && type != OP_SASSIGN
3208          && type != OP_ENTERLOOP)
3209             goto nomod;
3210         /* Don’t bother applying lvalue context to the ex-list.  */
3211         kid = cUNOPx(cUNOPo->op_first)->op_first;
3212         assert (!OpHAS_SIBLING(kid));
3213         goto kid_2lvref;
3214     case OP_REFGEN:
3215         if (type == OP_NULL) /* local */
3216             goto local_refgen;
3217         if (type != OP_AASSIGN) goto nomod;
3218         kid = cUNOPo->op_first;
3219       kid_2lvref:
3220         {
3221             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3222             S_lvref(aTHX_ kid, type);
3223             if (!PL_parser || PL_parser->error_count == ec) {
3224                 if (!FEATURE_REFALIASING_IS_ENABLED)
3225                     Perl_croak(aTHX_
3226                        "Experimental aliasing via reference not enabled");
3227                 Perl_ck_warner_d(aTHX_
3228                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3229                                 "Aliasing via reference is experimental");
3230             }
3231         }
3232         if (o->op_type == OP_REFGEN)
3233             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3234         op_null(o);
3235         return o;
3236
3237     case OP_SPLIT:
3238         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3239             /* This is actually @array = split.  */
3240             PL_modcount = RETURN_UNLIMITED_NUMBER;
3241             break;
3242         }
3243         goto nomod;
3244
3245     case OP_SCALAR:
3246         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3247         goto nomod;
3248     }
3249
3250     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3251        their argument is a filehandle; thus \stat(".") should not set
3252        it. AMS 20011102 */
3253     if (type == OP_REFGEN &&
3254         PL_check[o->op_type] == Perl_ck_ftst)
3255         return o;
3256
3257     if (type != OP_LEAVESUBLV)
3258         o->op_flags |= OPf_MOD;
3259
3260     if (type == OP_AASSIGN || type == OP_SASSIGN)
3261         o->op_flags |= OPf_SPECIAL
3262                       |(o->op_type == OP_ENTERSUB ? 0 : 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 && o->op_type != OP_ENTERSUB)
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         if (!FEATURE_MYREF_IS_ENABLED)
3777             Perl_croak(aTHX_ "The experimental declared_refs "
3778                              "feature is not enabled");
3779         Perl_ck_warner_d(aTHX_
3780              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3781             "Declaring references is experimental");
3782         /* Kid is a nulled OP_LIST, handled above.  */
3783         my_kid(cUNOPo->op_first, attrs, imopsp);
3784         return o;
3785     }
3786     else if (type != OP_PADSV &&
3787              type != OP_PADAV &&
3788              type != OP_PADHV &&
3789              type != OP_PUSHMARK)
3790     {
3791         S_cant_declare(aTHX_ o);
3792         return o;
3793     }
3794     else if (attrs && type != OP_PUSHMARK) {
3795         HV *stash;
3796
3797         assert(PL_parser);
3798         PL_parser->in_my = FALSE;
3799         PL_parser->in_my_stash = NULL;
3800
3801         /* check for C<my Dog $spot> when deciding package */
3802         stash = PAD_COMPNAME_TYPE(o->op_targ);
3803         if (!stash)
3804             stash = PL_curstash;
3805         apply_attrs_my(stash, o, attrs, imopsp);
3806     }
3807     o->op_flags |= OPf_MOD;
3808     o->op_private |= OPpLVAL_INTRO;
3809     if (stately)
3810         o->op_private |= OPpPAD_STATE;
3811     return o;
3812 }
3813
3814 OP *
3815 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3816 {
3817     OP *rops;
3818     int maybe_scalar = 0;
3819
3820     PERL_ARGS_ASSERT_MY_ATTRS;
3821
3822 /* [perl #17376]: this appears to be premature, and results in code such as
3823    C< our(%x); > executing in list mode rather than void mode */
3824 #if 0
3825     if (o->op_flags & OPf_PARENS)
3826         list(o);
3827     else
3828         maybe_scalar = 1;
3829 #else
3830     maybe_scalar = 1;
3831 #endif
3832     if (attrs)
3833         SAVEFREEOP(attrs);
3834     rops = NULL;
3835     o = my_kid(o, attrs, &rops);
3836     if (rops) {
3837         if (maybe_scalar && o->op_type == OP_PADSV) {
3838             o = scalar(op_append_list(OP_LIST, rops, o));
3839             o->op_private |= OPpLVAL_INTRO;
3840         }
3841         else {
3842             /* The listop in rops might have a pushmark at the beginning,
3843                which will mess up list assignment. */
3844             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3845             if (rops->op_type == OP_LIST && 
3846                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3847             {
3848                 OP * const pushmark = lrops->op_first;
3849                 /* excise pushmark */
3850                 op_sibling_splice(rops, NULL, 1, NULL);
3851                 op_free(pushmark);
3852             }
3853             o = op_append_list(OP_LIST, o, rops);
3854         }
3855     }
3856     PL_parser->in_my = FALSE;
3857     PL_parser->in_my_stash = NULL;
3858     return o;
3859 }
3860
3861 OP *
3862 Perl_sawparens(pTHX_ OP *o)
3863 {
3864     PERL_UNUSED_CONTEXT;
3865     if (o)
3866         o->op_flags |= OPf_PARENS;
3867     return o;
3868 }
3869
3870 OP *
3871 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3872 {
3873     OP *o;
3874     bool ismatchop = 0;
3875     const OPCODE ltype = left->op_type;
3876     const OPCODE rtype = right->op_type;
3877
3878     PERL_ARGS_ASSERT_BIND_MATCH;
3879
3880     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3881           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3882     {
3883       const char * const desc
3884           = PL_op_desc[(
3885                           rtype == OP_SUBST || rtype == OP_TRANS
3886                        || rtype == OP_TRANSR
3887                        )
3888                        ? (int)rtype : OP_MATCH];
3889       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3890       SV * const name =
3891         S_op_varname(aTHX_ left);
3892       if (name)
3893         Perl_warner(aTHX_ packWARN(WARN_MISC),
3894              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3895              desc, SVfARG(name), SVfARG(name));
3896       else {
3897         const char * const sample = (isary
3898              ? "@array" : "%hash");
3899         Perl_warner(aTHX_ packWARN(WARN_MISC),
3900              "Applying %s to %s will act on scalar(%s)",
3901              desc, sample, sample);
3902       }
3903     }
3904
3905     if (rtype == OP_CONST &&
3906         cSVOPx(right)->op_private & OPpCONST_BARE &&
3907         cSVOPx(right)->op_private & OPpCONST_STRICT)
3908     {
3909         no_bareword_allowed(right);
3910     }
3911
3912     /* !~ doesn't make sense with /r, so error on it for now */
3913     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3914         type == OP_NOT)
3915         /* diag_listed_as: Using !~ with %s doesn't make sense */
3916         yyerror("Using !~ with s///r doesn't make sense");
3917     if (rtype == OP_TRANSR && type == OP_NOT)
3918         /* diag_listed_as: Using !~ with %s doesn't make sense */
3919         yyerror("Using !~ with tr///r doesn't make sense");
3920
3921     ismatchop = (rtype == OP_MATCH ||
3922                  rtype == OP_SUBST ||
3923                  rtype == OP_TRANS || rtype == OP_TRANSR)
3924              && !(right->op_flags & OPf_SPECIAL);
3925     if (ismatchop && right->op_private & OPpTARGET_MY) {
3926         right->op_targ = 0;
3927         right->op_private &= ~OPpTARGET_MY;
3928     }
3929     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3930         if (left->op_type == OP_PADSV
3931          && !(left->op_private & OPpLVAL_INTRO))
3932         {
3933             right->op_targ = left->op_targ;
3934             op_free(left);
3935             o = right;
3936         }
3937         else {
3938             right->op_flags |= OPf_STACKED;
3939             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3940             ! (rtype == OP_TRANS &&
3941                right->op_private & OPpTRANS_IDENTICAL) &&
3942             ! (rtype == OP_SUBST &&
3943                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3944                 left = op_lvalue(left, rtype);
3945             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3946                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3947             else
3948                 o = op_prepend_elem(rtype, scalar(left), right);
3949         }
3950         if (type == OP_NOT)
3951             return newUNOP(OP_NOT, 0, scalar(o));
3952         return o;
3953     }
3954     else
3955         return bind_match(type, left,
3956                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3957 }
3958
3959 OP *
3960 Perl_invert(pTHX_ OP *o)
3961 {
3962     if (!o)
3963         return NULL;
3964     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3965 }
3966
3967 /*
3968 =for apidoc Amx|OP *|op_scope|OP *o
3969
3970 Wraps up an op tree with some additional ops so that at runtime a dynamic
3971 scope will be created.  The original ops run in the new dynamic scope,
3972 and then, provided that they exit normally, the scope will be unwound.
3973 The additional ops used to create and unwind the dynamic scope will
3974 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3975 instead if the ops are simple enough to not need the full dynamic scope
3976 structure.
3977
3978 =cut
3979 */
3980
3981 OP *
3982 Perl_op_scope(pTHX_ OP *o)
3983 {
3984     dVAR;
3985     if (o) {
3986         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3987             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3988             OpTYPE_set(o, OP_LEAVE);
3989         }
3990         else if (o->op_type == OP_LINESEQ) {
3991             OP *kid;
3992             OpTYPE_set(o, OP_SCOPE);
3993             kid = ((LISTOP*)o)->op_first;
3994             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3995                 op_null(kid);
3996
3997                 /* The following deals with things like 'do {1 for 1}' */
3998                 kid = OpSIBLING(kid);
3999                 if (kid &&
4000                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4001                     op_null(kid);
4002             }
4003         }
4004         else
4005             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4006     }
4007     return o;
4008 }
4009
4010 OP *
4011 Perl_op_unscope(pTHX_ OP *o)
4012 {
4013     if (o && o->op_type == OP_LINESEQ) {
4014         OP *kid = cLISTOPo->op_first;
4015         for(; kid; kid = OpSIBLING(kid))
4016             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4017                 op_null(kid);
4018     }
4019     return o;
4020 }
4021
4022 /*
4023 =for apidoc Am|int|block_start|int full
4024
4025 Handles compile-time scope entry.
4026 Arranges for hints to be restored on block
4027 exit and also handles pad sequence numbers to make lexical variables scope
4028 right.  Returns a savestack index for use with C<block_end>.
4029
4030 =cut
4031 */
4032
4033 int
4034 Perl_block_start(pTHX_ int full)
4035 {
4036     const int retval = PL_savestack_ix;
4037
4038     PL_compiling.cop_seq = PL_cop_seqmax;
4039     COP_SEQMAX_INC;
4040     pad_block_start(full);
4041     SAVEHINTS();
4042     PL_hints &= ~HINT_BLOCK_SCOPE;
4043     SAVECOMPILEWARNINGS();
4044     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4045     SAVEI32(PL_compiling.cop_seq);
4046     PL_compiling.cop_seq = 0;
4047
4048     CALL_BLOCK_HOOKS(bhk_start, full);
4049
4050     return retval;
4051 }
4052
4053 /*
4054 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4055
4056 Handles compile-time scope exit.  C<floor>
4057 is the savestack index returned by
4058 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4059 possibly modified.
4060
4061 =cut
4062 */
4063
4064 OP*
4065 Perl_block_end(pTHX_ I32 floor, OP *seq)
4066 {
4067     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4068     OP* retval = scalarseq(seq);
4069     OP *o;
4070
4071     /* XXX Is the null PL_parser check necessary here? */
4072     assert(PL_parser); /* Let’s find out under debugging builds.  */
4073     if (PL_parser && PL_parser->parsed_sub) {
4074         o = newSTATEOP(0, NULL, NULL);
4075         op_null(o);
4076         retval = op_append_elem(OP_LINESEQ, retval, o);
4077     }
4078
4079     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4080
4081     LEAVE_SCOPE(floor);
4082     if (needblockscope)
4083         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4084     o = pad_leavemy();
4085
4086     if (o) {
4087         /* pad_leavemy has created a sequence of introcv ops for all my
4088            subs declared in the block.  We have to replicate that list with
4089            clonecv ops, to deal with this situation:
4090
4091                sub {
4092                    my sub s1;
4093                    my sub s2;
4094                    sub s1 { state sub foo { \&s2 } }
4095                }->()
4096
4097            Originally, I was going to have introcv clone the CV and turn
4098            off the stale flag.  Since &s1 is declared before &s2, the
4099            introcv op for &s1 is executed (on sub entry) before the one for
4100            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4101            cloned, since it is a state sub) closes over &s2 and expects
4102            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4103            then &s2 is still marked stale.  Since &s1 is not active, and
4104            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4105            ble will not stay shared’ warning.  Because it is the same stub
4106            that will be used when the introcv op for &s2 is executed, clos-
4107            ing over it is safe.  Hence, we have to turn off the stale flag
4108            on all lexical subs in the block before we clone any of them.
4109            Hence, having introcv clone the sub cannot work.  So we create a
4110            list of ops like this:
4111
4112                lineseq
4113                   |
4114                   +-- introcv
4115                   |
4116                   +-- introcv
4117                   |
4118                   +-- introcv
4119                   |
4120                   .
4121                   .
4122                   .
4123                   |
4124                   +-- clonecv
4125                   |
4126                   +-- clonecv
4127                   |
4128                   +-- clonecv
4129                   |
4130                   .
4131                   .
4132                   .
4133          */
4134         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4135         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4136         for (;; kid = OpSIBLING(kid)) {
4137             OP *newkid = newOP(OP_CLONECV, 0);
4138             newkid->op_targ = kid->op_targ;
4139             o = op_append_elem(OP_LINESEQ, o, newkid);
4140             if (kid == last) break;
4141         }
4142         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4143     }
4144
4145     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4146
4147     return retval;
4148 }
4149
4150 /*
4151 =head1 Compile-time scope hooks
4152
4153 =for apidoc Aox||blockhook_register
4154
4155 Register a set of hooks to be called when the Perl lexical scope changes
4156 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4157
4158 =cut
4159 */
4160
4161 void
4162 Perl_blockhook_register(pTHX_ BHK *hk)
4163 {
4164     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4165
4166     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4167 }
4168
4169 void
4170 Perl_newPROG(pTHX_ OP *o)
4171 {
4172     PERL_ARGS_ASSERT_NEWPROG;
4173
4174     if (PL_in_eval) {
4175         PERL_CONTEXT *cx;
4176         I32 i;
4177         if (PL_eval_root)
4178                 return;
4179         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4180                                ((PL_in_eval & EVAL_KEEPERR)
4181                                 ? OPf_SPECIAL : 0), o);
4182
4183         cx = CX_CUR();
4184         assert(CxTYPE(cx) == CXt_EVAL);
4185
4186         if ((cx->blk_gimme & G_WANT) == G_VOID)
4187             scalarvoid(PL_eval_root);
4188         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4189             list(PL_eval_root);
4190         else
4191             scalar(PL_eval_root);
4192
4193         PL_eval_start = op_linklist(PL_eval_root);
4194         PL_eval_root->op_private |= OPpREFCOUNTED;
4195         OpREFCNT_set(PL_eval_root, 1);
4196         PL_eval_root->op_next = 0;
4197         i = PL_savestack_ix;
4198         SAVEFREEOP(o);
4199         ENTER;
4200         CALL_PEEP(PL_eval_start);
4201         finalize_optree(PL_eval_root);
4202         S_prune_chain_head(&PL_eval_start);
4203         LEAVE;
4204         PL_savestack_ix = i;
4205     }
4206     else {
4207         if (o->op_type == OP_STUB) {
4208             /* This block is entered if nothing is compiled for the main
4209                program. This will be the case for an genuinely empty main
4210                program, or one which only has BEGIN blocks etc, so already
4211                run and freed.
4212
4213                Historically (5.000) the guard above was !o. However, commit
4214                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4215                c71fccf11fde0068, changed perly.y so that newPROG() is now
4216                called with the output of block_end(), which returns a new
4217                OP_STUB for the case of an empty optree. ByteLoader (and
4218                maybe other things) also take this path, because they set up
4219                PL_main_start and PL_main_root directly, without generating an
4220                optree.
4221
4222                If the parsing the main program aborts (due to parse errors,
4223                or due to BEGIN or similar calling exit), then newPROG()
4224                isn't even called, and hence this code path and its cleanups
4225                are skipped. This shouldn't make a make a difference:
4226                * a non-zero return from perl_parse is a failure, and
4227                  perl_destruct() should be called immediately.
4228                * however, if exit(0) is called during the parse, then
4229                  perl_parse() returns 0, and perl_run() is called. As
4230                  PL_main_start will be NULL, perl_run() will return
4231                  promptly, and the exit code will remain 0.
4232             */
4233
4234             PL_comppad_name = 0;
4235             PL_compcv = 0;
4236             S_op_destroy(aTHX_ o);
4237             return;
4238         }
4239         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4240         PL_curcop = &PL_compiling;
4241         PL_main_start = LINKLIST(PL_main_root);
4242         PL_main_root->op_private |= OPpREFCOUNTED;
4243         OpREFCNT_set(PL_main_root, 1);
4244         PL_main_root->op_next = 0;
4245         CALL_PEEP(PL_main_start);
4246         finalize_optree(PL_main_root);
4247         S_prune_chain_head(&PL_main_start);
4248         cv_forget_slab(PL_compcv);
4249         PL_compcv = 0;
4250
4251         /* Register with debugger */
4252         if (PERLDB_INTER) {
4253             CV * const cv = get_cvs("DB::postponed", 0);
4254             if (cv) {
4255                 dSP;
4256                 PUSHMARK(SP);
4257                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4258                 PUTBACK;
4259                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4260             }
4261         }
4262     }
4263 }
4264
4265 OP *
4266 Perl_localize(pTHX_ OP *o, I32 lex)
4267 {
4268     PERL_ARGS_ASSERT_LOCALIZE;
4269
4270     if (o->op_flags & OPf_PARENS)
4271 /* [perl #17376]: this appears to be premature, and results in code such as
4272    C< our(%x); > executing in list mode rather than void mode */
4273 #if 0
4274         list(o);
4275 #else
4276         NOOP;
4277 #endif
4278     else {
4279         if ( PL_parser->bufptr > PL_parser->oldbufptr
4280             && PL_parser->bufptr[-1] == ','
4281             && ckWARN(WARN_PARENTHESIS))
4282         {
4283             char *s = PL_parser->bufptr;
4284             bool sigil = FALSE;
4285
4286             /* some heuristics to detect a potential error */
4287             while (*s && (strchr(", \t\n", *s)))
4288                 s++;
4289
4290             while (1) {
4291                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4292                        && *++s
4293                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4294                     s++;
4295                     sigil = TRUE;
4296                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4297                         s++;
4298                     while (*s && (strchr(", \t\n", *s)))
4299                         s++;
4300                 }
4301                 else
4302                     break;
4303             }
4304             if (sigil && (*s == ';' || *s == '=')) {
4305                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4306                                 "Parentheses missing around \"%s\" list",
4307                                 lex
4308                                     ? (PL_parser->in_my == KEY_our
4309                                         ? "our"
4310                                         : PL_parser->in_my == KEY_state
4311                                             ? "state"
4312                                             : "my")
4313                                     : "local");
4314             }
4315         }
4316     }
4317     if (lex)
4318         o = my(o);
4319     else
4320         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4321     PL_parser->in_my = FALSE;
4322     PL_parser->in_my_stash = NULL;
4323     return o;
4324 }
4325
4326 OP *
4327 Perl_jmaybe(pTHX_ OP *o)
4328 {
4329     PERL_ARGS_ASSERT_JMAYBE;
4330
4331     if (o->op_type == OP_LIST) {
4332         OP * const o2
4333             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4334         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4335     }
4336     return o;
4337 }
4338
4339 PERL_STATIC_INLINE OP *
4340 S_op_std_init(pTHX_ OP *o)
4341 {
4342     I32 type = o->op_type;
4343
4344     PERL_ARGS_ASSERT_OP_STD_INIT;
4345
4346     if (PL_opargs[type] & OA_RETSCALAR)
4347         scalar(o);
4348     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4349         o->op_targ = pad_alloc(type, SVs_PADTMP);
4350
4351     return o;
4352 }
4353
4354 PERL_STATIC_INLINE OP *
4355 S_op_integerize(pTHX_ OP *o)
4356 {
4357     I32 type = o->op_type;
4358
4359     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4360
4361     /* integerize op. */
4362     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4363     {
4364         dVAR;
4365         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4366     }
4367
4368     if (type == OP_NEGATE)
4369         /* XXX might want a ck_negate() for this */
4370         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4371
4372     return o;
4373 }
4374
4375 static OP *
4376 S_fold_constants(pTHX_ OP *o)
4377 {
4378     dVAR;
4379     OP * VOL curop;
4380     OP *newop;
4381     VOL I32 type = o->op_type;
4382     bool is_stringify;
4383     SV * VOL sv = NULL;
4384     int ret = 0;
4385     OP *old_next;
4386     SV * const oldwarnhook = PL_warnhook;
4387     SV * const olddiehook  = PL_diehook;
4388     COP not_compiling;
4389     U8 oldwarn = PL_dowarn;
4390     I32 old_cxix;
4391     dJMPENV;
4392
4393     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4394
4395     if (!(PL_opargs[type] & OA_FOLDCONST))
4396         goto nope;
4397
4398     switch (type) {
4399     case OP_UCFIRST:
4400     case OP_LCFIRST:
4401     case OP_UC:
4402     case OP_LC:
4403     case OP_FC:
4404 #ifdef USE_LOCALE_CTYPE
4405         if (IN_LC_COMPILETIME(LC_CTYPE))
4406             goto nope;
4407 #endif
4408         break;
4409     case OP_SLT:
4410     case OP_SGT:
4411     case OP_SLE:
4412     case OP_SGE:
4413     case OP_SCMP:
4414 #ifdef USE_LOCALE_COLLATE
4415         if (IN_LC_COMPILETIME(LC_COLLATE))
4416             goto nope;
4417 #endif
4418         break;
4419     case OP_SPRINTF:
4420         /* XXX what about the numeric ops? */
4421 #ifdef USE_LOCALE_NUMERIC
4422         if (IN_LC_COMPILETIME(LC_NUMERIC))
4423             goto nope;
4424 #endif
4425         break;
4426     case OP_PACK:
4427         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4428           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4429             goto nope;
4430         {
4431             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4432             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4433             {
4434                 const char *s = SvPVX_const(sv);
4435                 while (s < SvEND(sv)) {
4436                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4437                     s++;
4438                 }
4439             }
4440         }
4441         break;
4442     case OP_REPEAT:
4443         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4444         break;
4445     case OP_SREFGEN:
4446         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4447          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4448             goto nope;
4449     }
4450
4451     if (PL_parser && PL_parser->error_count)
4452         goto nope;              /* Don't try to run w/ errors */
4453
4454     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4455         switch (curop->op_type) {
4456         case OP_CONST:
4457             if (   (curop->op_private & OPpCONST_BARE)
4458                 && (curop->op_private & OPpCONST_STRICT)) {
4459                 no_bareword_allowed(curop);
4460                 goto nope;
4461             }
4462             /* FALLTHROUGH */
4463         case OP_LIST:
4464         case OP_SCALAR:
4465         case OP_NULL:
4466         case OP_PUSHMARK:
4467             /* Foldable; move to next op in list */
4468             break;
4469
4470         default:
4471             /* No other op types are considered foldable */
4472             goto nope;
4473         }
4474     }
4475
4476     curop = LINKLIST(o);
4477     old_next = o->op_next;
4478     o->op_next = 0;
4479     PL_op = curop;
4480
4481     old_cxix = cxstack_ix;
4482     create_eval_scope(NULL, G_FAKINGEVAL);
4483
4484     /* Verify that we don't need to save it:  */
4485     assert(PL_curcop == &PL_compiling);
4486     StructCopy(&PL_compiling, &not_compiling, COP);
4487     PL_curcop = &not_compiling;
4488     /* The above ensures that we run with all the correct hints of the
4489        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4490     assert(IN_PERL_RUNTIME);
4491     PL_warnhook = PERL_WARNHOOK_FATAL;
4492     PL_diehook  = NULL;
4493     JMPENV_PUSH(ret);
4494
4495     /* Effective $^W=1.  */
4496     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4497         PL_dowarn |= G_WARN_ON;
4498
4499     switch (ret) {
4500     case 0:
4501         CALLRUNOPS(aTHX);
4502         sv = *(PL_stack_sp--);
4503         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4504             pad_swipe(o->op_targ,  FALSE);
4505         }
4506         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4507             SvREFCNT_inc_simple_void(sv);
4508             SvTEMP_off(sv);
4509         }
4510         else { assert(SvIMMORTAL(sv)); }
4511         break;
4512     case 3:
4513         /* Something tried to die.  Abandon constant folding.  */
4514         /* Pretend the error never happened.  */
4515         CLEAR_ERRSV();
4516         o->op_next = old_next;
4517         break;
4518     default:
4519         JMPENV_POP;
4520         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4521         PL_warnhook = oldwarnhook;
4522         PL_diehook  = olddiehook;
4523         /* XXX note that this croak may fail as we've already blown away
4524          * the stack - eg any nested evals */
4525         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4526     }
4527     JMPENV_POP;
4528     PL_dowarn   = oldwarn;
4529     PL_warnhook = oldwarnhook;
4530     PL_diehook  = olddiehook;
4531     PL_curcop = &PL_compiling;
4532
4533     /* if we croaked, depending on how we croaked the eval scope
4534      * may or may not have already been popped */
4535     if (cxstack_ix > old_cxix) {
4536         assert(cxstack_ix == old_cxix + 1);
4537         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4538         delete_eval_scope();
4539     }
4540     if (ret)
4541         goto nope;
4542
4543     /* OP_STRINGIFY and constant folding are used to implement qq.
4544        Here the constant folding is an implementation detail that we
4545        want to hide.  If the stringify op is itself already marked
4546        folded, however, then it is actually a folded join.  */
4547     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4548     op_free(o);
4549     assert(sv);
4550     if (is_stringify)
4551         SvPADTMP_off(sv);
4552     else if (!SvIMMORTAL(sv)) {
4553         SvPADTMP_on(sv);
4554         SvREADONLY_on(sv);
4555     }
4556     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4557     if (!is_stringify) newop->op_folded = 1;
4558     return newop;
4559
4560  nope:
4561     return o;
4562 }
4563
4564 static OP *
4565 S_gen_constant_list(pTHX_ OP *o)
4566 {
4567     dVAR;
4568     OP *curop;
4569     const SSize_t oldtmps_floor = PL_tmps_floor;
4570     SV **svp;
4571     AV *av;
4572
4573     list(o);
4574     if (PL_parser && PL_parser->error_count)
4575         return o;               /* Don't attempt to run with errors */
4576
4577     curop = LINKLIST(o);
4578     o->op_next = 0;
4579     CALL_PEEP(curop);
4580     S_prune_chain_head(&curop);
4581     PL_op = curop;
4582     Perl_pp_pushmark(aTHX);
4583     CALLRUNOPS(aTHX);
4584     PL_op = curop;
4585     assert (!(curop->op_flags & OPf_SPECIAL));
4586     assert(curop->op_type == OP_RANGE);
4587     Perl_pp_anonlist(aTHX);
4588     PL_tmps_floor = oldtmps_floor;
4589
4590     OpTYPE_set(o, OP_RV2AV);
4591     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4592     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4593     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4594     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4595
4596     /* replace subtree with an OP_CONST */
4597     curop = ((UNOP*)o)->op_first;
4598     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4599     op_free(curop);
4600
4601     if (AvFILLp(av) != -1)
4602         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4603         {
4604             SvPADTMP_on(*svp);
4605             SvREADONLY_on(*svp);
4606         }
4607     LINKLIST(o);
4608     return list(o);
4609 }
4610
4611 /*
4612 =head1 Optree Manipulation Functions
4613 */
4614
4615 /* List constructors */
4616
4617 /*
4618 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4619
4620 Append an item to the list of ops contained directly within a list-type
4621 op, returning the lengthened list.  C<first> is the list-type op,
4622 and C<last> is the op to append to the list.  C<optype> specifies the
4623 intended opcode for the list.  If C<first> is not already a list of the
4624 right type, it will be upgraded into one.  If either C<first> or C<last>
4625 is null, the other is returned unchanged.
4626
4627 =cut
4628 */
4629
4630 OP *
4631 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4632 {
4633     if (!first)
4634         return last;
4635
4636     if (!last)
4637         return first;
4638
4639     if (first->op_type != (unsigned)type
4640         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4641     {
4642         return newLISTOP(type, 0, first, last);
4643     }
4644
4645     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4646     first->op_flags |= OPf_KIDS;
4647     return first;
4648 }
4649
4650 /*
4651 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4652
4653 Concatenate the lists of ops contained directly within two list-type ops,
4654 returning the combined list.  C<first> and C<last> are the list-type ops
4655 to concatenate.  C<optype> specifies the intended opcode for the list.
4656 If either C<first> or C<last> is not already a list of the right type,
4657 it will be upgraded into one.  If either C<first> or C<last> is null,
4658 the other is returned unchanged.
4659
4660 =cut
4661 */
4662
4663 OP *
4664 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4665 {
4666     if (!first)
4667         return last;
4668
4669     if (!last)
4670         return first;
4671
4672     if (first->op_type != (unsigned)type)
4673         return op_prepend_elem(type, first, last);
4674
4675     if (last->op_type != (unsigned)type)
4676         return op_append_elem(type, first, last);
4677
4678     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4679     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4680     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4681     first->op_flags |= (last->op_flags & OPf_KIDS);
4682
4683     S_op_destroy(aTHX_ last);
4684
4685     return first;
4686 }
4687
4688 /*
4689 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4690
4691 Prepend an item to the list of ops contained directly within a list-type
4692 op, returning the lengthened list.  C<first> is the op to prepend to the
4693 list, and C<last> is the list-type op.  C<optype> specifies the intended
4694 opcode for the list.  If C<last> is not already a list of the right type,
4695 it will be upgraded into one.  If either C<first> or C<last> is null,
4696 the other is returned unchanged.
4697
4698 =cut
4699 */
4700
4701 OP *
4702 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4703 {
4704     if (!first)
4705         return last;
4706
4707     if (!last)
4708         return first;
4709
4710     if (last->op_type == (unsigned)type) {
4711         if (type == OP_LIST) {  /* already a PUSHMARK there */
4712             /* insert 'first' after pushmark */
4713             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4714             if (!(first->op_flags & OPf_PARENS))
4715                 last->op_flags &= ~OPf_PARENS;
4716         }
4717         else
4718             op_sibling_splice(last, NULL, 0, first);
4719         last->op_flags |= OPf_KIDS;
4720         return last;
4721     }
4722
4723     return newLISTOP(type, 0, first, last);
4724 }
4725
4726 /*
4727 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4728
4729 Converts C<o> into a list op if it is not one already, and then converts it
4730 into the specified C<type>, calling its check function, allocating a target if
4731 it needs one, and folding constants.
4732
4733 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4734 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4735 C<op_convert_list> to make it the right type.
4736
4737 =cut
4738 */
4739
4740 OP *
4741 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4742 {
4743     dVAR;
4744     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4745     if (!o || o->op_type != OP_LIST)
4746         o = force_list(o, 0);
4747     else
4748     {
4749         o->op_flags &= ~OPf_WANT;
4750         o->op_private &= ~OPpLVAL_INTRO;
4751     }
4752
4753     if (!(PL_opargs[type] & OA_MARK))
4754         op_null(cLISTOPo->op_first);
4755     else {
4756         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4757         if (kid2 && kid2->op_type == OP_COREARGS) {
4758             op_null(cLISTOPo->op_first);
4759             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4760         }
4761     }
4762
4763     if (type != OP_SPLIT)
4764         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4765          * ck_split() create a real PMOP and leave the op's type as listop
4766          * for for now. Otherwise op_free() etc will crash.
4767          */
4768         OpTYPE_set(o, type);
4769
4770     o->op_flags |= flags;
4771     if (flags & OPf_FOLDED)
4772         o->op_folded = 1;
4773
4774     o = CHECKOP(type, o);
4775     if (o->op_type != (unsigned)type)
4776         return o;
4777
4778     return fold_constants(op_integerize(op_std_init(o)));
4779 }
4780
4781 /* Constructors */
4782
4783
4784 /*
4785 =head1 Optree construction
4786
4787 =for apidoc Am|OP *|newNULLLIST
4788
4789 Constructs, checks, and returns a new C<stub> op, which represents an
4790 empty list expression.
4791
4792 =cut
4793 */
4794
4795 OP *
4796 Perl_newNULLLIST(pTHX)
4797 {
4798     return newOP(OP_STUB, 0);
4799 }
4800
4801 /* promote o and any siblings to be a list if its not already; i.e.
4802  *
4803  *  o - A - B
4804  *
4805  * becomes
4806  *
4807  *  list
4808  *    |
4809  *  pushmark - o - A - B
4810  *
4811  * If nullit it true, the list op is nulled.
4812  */
4813
4814 static OP *
4815 S_force_list(pTHX_ OP *o, bool nullit)
4816 {
4817     if (!o || o->op_type != OP_LIST) {
4818         OP *rest = NULL;
4819         if (o) {
4820             /* manually detach any siblings then add them back later */