51ffac2ac5bb01a90283b9f2d5635f0fb81f880e
[perl.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 #ifdef DEBUGGING
491     size_t savestack_count = 0;
492 #endif
493     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
494     slab2 = slab;
495     do {
496         OPSLOT *slot;
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)
659                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
660             || (name[1] == '_' && len > 2)))
661     {
662         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
663          && isASCII(name[1])
664          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
665             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
666                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
667                               PL_parser->in_my == KEY_state ? "state" : "my"));
668         } else {
669             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
670                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
671         }
672     }
673
674     /* allocate a spare slot and store the name in that slot */
675
676     off = pad_add_name_pvn(name, len,
677                        (is_our ? padadd_OUR :
678                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
679                     PL_parser->in_my_stash,
680                     (is_our
681                         /* $_ is always in main::, even with our */
682                         ? (PL_curstash && !memEQs(name,len,"$_")
683                             ? PL_curstash
684                             : PL_defstash)
685                         : NULL
686                     )
687     );
688     /* anon sub prototypes contains state vars should always be cloned,
689      * otherwise the state var would be shared between anon subs */
690
691     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
692         CvCLONE_on(PL_compcv);
693
694     return off;
695 }
696
697 /*
698 =head1 Optree Manipulation Functions
699
700 =for apidoc alloccopstash
701
702 Available only under threaded builds, this function allocates an entry in
703 C<PL_stashpad> for the stash passed to it.
704
705 =cut
706 */
707
708 #ifdef USE_ITHREADS
709 PADOFFSET
710 Perl_alloccopstash(pTHX_ HV *hv)
711 {
712     PADOFFSET off = 0, o = 1;
713     bool found_slot = FALSE;
714
715     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
716
717     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
718
719     for (; o < PL_stashpadmax; ++o) {
720         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
721         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
722             found_slot = TRUE, off = o;
723     }
724     if (!found_slot) {
725         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
726         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
727         off = PL_stashpadmax;
728         PL_stashpadmax += 10;
729     }
730
731     PL_stashpad[PL_stashpadix = off] = hv;
732     return off;
733 }
734 #endif
735
736 /* free the body of an op without examining its contents.
737  * Always use this rather than FreeOp directly */
738
739 static void
740 S_op_destroy(pTHX_ OP *o)
741 {
742     FreeOp(o);
743 }
744
745 /* Destructor */
746
747 /*
748 =for apidoc Am|void|op_free|OP *o
749
750 Free an op.  Only use this when an op is no longer linked to from any
751 optree.
752
753 =cut
754 */
755
756 void
757 Perl_op_free(pTHX_ OP *o)
758 {
759     dVAR;
760     OPCODE type;
761     SSize_t defer_ix = -1;
762     SSize_t defer_stack_alloc = 0;
763     OP **defer_stack = NULL;
764
765     do {
766
767         /* Though ops may be freed twice, freeing the op after its slab is a
768            big no-no. */
769         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
770         /* During the forced freeing of ops after compilation failure, kidops
771            may be freed before their parents. */
772         if (!o || o->op_type == OP_FREED)
773             continue;
774
775         type = o->op_type;
776
777         /* an op should only ever acquire op_private flags that we know about.
778          * If this fails, you may need to fix something in regen/op_private.
779          * Don't bother testing if:
780          *   * the op_ppaddr doesn't match the op; someone may have
781          *     overridden the op and be doing strange things with it;
782          *   * we've errored, as op flags are often left in an
783          *     inconsistent state then. Note that an error when
784          *     compiling the main program leaves PL_parser NULL, so
785          *     we can't spot faults in the main code, only
786          *     evaled/required code */
787 #ifdef DEBUGGING
788         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
789             && PL_parser
790             && !PL_parser->error_count)
791         {
792             assert(!(o->op_private & ~PL_op_private_valid[type]));
793         }
794 #endif
795
796         if (o->op_private & OPpREFCOUNTED) {
797             switch (type) {
798             case OP_LEAVESUB:
799             case OP_LEAVESUBLV:
800             case OP_LEAVEEVAL:
801             case OP_LEAVE:
802             case OP_SCOPE:
803             case OP_LEAVEWRITE:
804                 {
805                 PADOFFSET refcnt;
806                 OP_REFCNT_LOCK;
807                 refcnt = OpREFCNT_dec(o);
808                 OP_REFCNT_UNLOCK;
809                 if (refcnt) {
810                     /* Need to find and remove any pattern match ops from the list
811                        we maintain for reset().  */
812                     find_and_forget_pmops(o);
813                     continue;
814                 }
815                 }
816                 break;
817             default:
818                 break;
819             }
820         }
821
822         /* Call the op_free hook if it has been set. Do it now so that it's called
823          * at the right time for refcounted ops, but still before all of the kids
824          * are freed. */
825         CALL_OPFREEHOOK(o);
826
827         if (o->op_flags & OPf_KIDS) {
828             OP *kid, *nextkid;
829             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
830                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
831                 if (!kid || kid->op_type == OP_FREED)
832                     /* During the forced freeing of ops after
833                        compilation failure, kidops may be freed before
834                        their parents. */
835                     continue;
836                 if (!(kid->op_flags & OPf_KIDS))
837                     /* If it has no kids, just free it now */
838                     op_free(kid);
839                 else
840                     DEFER_OP(kid);
841             }
842         }
843         if (type == OP_NULL)
844             type = (OPCODE)o->op_targ;
845
846         if (o->op_slabbed)
847             Slab_to_rw(OpSLAB(o));
848
849         /* COP* is not cleared by op_clear() so that we may track line
850          * numbers etc even after null() */
851         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
852             cop_free((COP*)o);
853         }
854
855         op_clear(o);
856         FreeOp(o);
857         if (PL_op == o)
858             PL_op = NULL;
859     } while ( (o = POP_DEFERRED_OP()) );
860
861     Safefree(defer_stack);
862 }
863
864 /* S_op_clear_gv(): free a GV attached to an OP */
865
866 STATIC
867 #ifdef USE_ITHREADS
868 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
869 #else
870 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
871 #endif
872 {
873
874     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
875             || o->op_type == OP_MULTIDEREF)
876 #ifdef USE_ITHREADS
877                 && PL_curpad
878                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
879 #else
880                 ? (GV*)(*svp) : NULL;
881 #endif
882     /* It's possible during global destruction that the GV is freed
883        before the optree. Whilst the SvREFCNT_inc is happy to bump from
884        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
885        will trigger an assertion failure, because the entry to sv_clear
886        checks that the scalar is not already freed.  A check of for
887        !SvIS_FREED(gv) turns out to be invalid, because during global
888        destruction the reference count can be forced down to zero
889        (with SVf_BREAK set).  In which case raising to 1 and then
890        dropping to 0 triggers cleanup before it should happen.  I
891        *think* that this might actually be a general, systematic,
892        weakness of the whole idea of SVf_BREAK, in that code *is*
893        allowed to raise and lower references during global destruction,
894        so any *valid* code that happens to do this during global
895        destruction might well trigger premature cleanup.  */
896     bool still_valid = gv && SvREFCNT(gv);
897
898     if (still_valid)
899         SvREFCNT_inc_simple_void(gv);
900 #ifdef USE_ITHREADS
901     if (*ixp > 0) {
902         pad_swipe(*ixp, TRUE);
903         *ixp = 0;
904     }
905 #else
906     SvREFCNT_dec(*svp);
907     *svp = NULL;
908 #endif
909     if (still_valid) {
910         int try_downgrade = SvREFCNT(gv) == 2;
911         SvREFCNT_dec_NN(gv);
912         if (try_downgrade)
913             gv_try_downgrade(gv);
914     }
915 }
916
917
918 void
919 Perl_op_clear(pTHX_ OP *o)
920 {
921
922     dVAR;
923
924     PERL_ARGS_ASSERT_OP_CLEAR;
925
926     switch (o->op_type) {
927     case OP_NULL:       /* Was holding old type, if any. */
928         /* FALLTHROUGH */
929     case OP_ENTERTRY:
930     case OP_ENTEREVAL:  /* Was holding hints. */
931     case OP_ARGDEFELEM: /* Was holding signature index. */
932         o->op_targ = 0;
933         break;
934     default:
935         if (!(o->op_flags & OPf_REF)
936             || (PL_check[o->op_type] != Perl_ck_ftst))
937             break;
938         /* FALLTHROUGH */
939     case OP_GVSV:
940     case OP_GV:
941     case OP_AELEMFAST:
942 #ifdef USE_ITHREADS
943             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
944 #else
945             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
946 #endif
947         break;
948     case OP_METHOD_REDIR:
949     case OP_METHOD_REDIR_SUPER:
950 #ifdef USE_ITHREADS
951         if (cMETHOPx(o)->op_rclass_targ) {
952             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
953             cMETHOPx(o)->op_rclass_targ = 0;
954         }
955 #else
956         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
957         cMETHOPx(o)->op_rclass_sv = NULL;
958 #endif
959     case OP_METHOD_NAMED:
960     case OP_METHOD_SUPER:
961         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
962         cMETHOPx(o)->op_u.op_meth_sv = NULL;
963 #ifdef USE_ITHREADS
964         if (o->op_targ) {
965             pad_swipe(o->op_targ, 1);
966             o->op_targ = 0;
967         }
968 #endif
969         break;
970     case OP_CONST:
971     case OP_HINTSEVAL:
972         SvREFCNT_dec(cSVOPo->op_sv);
973         cSVOPo->op_sv = NULL;
974 #ifdef USE_ITHREADS
975         /** Bug #15654
976           Even if op_clear does a pad_free for the target of the op,
977           pad_free doesn't actually remove the sv that exists in the pad;
978           instead it lives on. This results in that it could be reused as 
979           a target later on when the pad was reallocated.
980         **/
981         if(o->op_targ) {
982           pad_swipe(o->op_targ,1);
983           o->op_targ = 0;
984         }
985 #endif
986         break;
987     case OP_DUMP:
988     case OP_GOTO:
989     case OP_NEXT:
990     case OP_LAST:
991     case OP_REDO:
992         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
993             break;
994         /* FALLTHROUGH */
995     case OP_TRANS:
996     case OP_TRANSR:
997         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
998             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
999         {
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 bool h = o->op_type == OP_HSLICE
1675                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1676     const char lbrack =
1677         h ? '{' : '[';
1678     const char rbrack =
1679         h ? '}' : ']';
1680     SV *name;
1681     SV *keysv = NULL; /* just to silence compiler warnings */
1682     const char *key = NULL;
1683
1684     if (!(o->op_private & OPpSLICEWARNING))
1685         return;
1686     if (PL_parser && PL_parser->error_count)
1687         /* This warning can be nonsensical when there is a syntax error. */
1688         return;
1689
1690     kid = cLISTOPo->op_first;
1691     kid = OpSIBLING(kid); /* get past pushmark */
1692     /* weed out false positives: any ops that can return lists */
1693     switch (kid->op_type) {
1694     case OP_BACKTICK:
1695     case OP_GLOB:
1696     case OP_READLINE:
1697     case OP_MATCH:
1698     case OP_RV2AV:
1699     case OP_EACH:
1700     case OP_VALUES:
1701     case OP_KEYS:
1702     case OP_SPLIT:
1703     case OP_LIST:
1704     case OP_SORT:
1705     case OP_REVERSE:
1706     case OP_ENTERSUB:
1707     case OP_CALLER:
1708     case OP_LSTAT:
1709     case OP_STAT:
1710     case OP_READDIR:
1711     case OP_SYSTEM:
1712     case OP_TMS:
1713     case OP_LOCALTIME:
1714     case OP_GMTIME:
1715     case OP_ENTEREVAL:
1716         return;
1717     }
1718
1719     /* Don't warn if we have a nulled list either. */
1720     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1721         return;
1722
1723     assert(OpSIBLING(kid));
1724     name = S_op_varname(aTHX_ OpSIBLING(kid));
1725     if (!name) /* XS module fiddling with the op tree */
1726         return;
1727     S_op_pretty(aTHX_ kid, &keysv, &key);
1728     assert(SvPOK(name));
1729     sv_chop(name,SvPVX(name)+1);
1730     if (key)
1731        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1732         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1733                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1734                    "%c%s%c",
1735                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1736                     lbrack, key, rbrack);
1737     else
1738        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1739         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1740                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1741                     SVf "%c%" SVf "%c",
1742                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1743                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1744 }
1745
1746 OP *
1747 Perl_scalar(pTHX_ OP *o)
1748 {
1749     OP *kid;
1750
1751     /* assumes no premature commitment */
1752     if (!o || (PL_parser && PL_parser->error_count)
1753          || (o->op_flags & OPf_WANT)
1754          || o->op_type == OP_RETURN)
1755     {
1756         return o;
1757     }
1758
1759     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1760
1761     switch (o->op_type) {
1762     case OP_REPEAT:
1763         scalar(cBINOPo->op_first);
1764         if (o->op_private & OPpREPEAT_DOLIST) {
1765             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1766             assert(kid->op_type == OP_PUSHMARK);
1767             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1768                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1769                 o->op_private &=~ OPpREPEAT_DOLIST;
1770             }
1771         }
1772         break;
1773     case OP_OR:
1774     case OP_AND:
1775     case OP_COND_EXPR:
1776         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1777             scalar(kid);
1778         break;
1779         /* FALLTHROUGH */
1780     case OP_SPLIT:
1781     case OP_MATCH:
1782     case OP_QR:
1783     case OP_SUBST:
1784     case OP_NULL:
1785     default:
1786         if (o->op_flags & OPf_KIDS) {
1787             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1788                 scalar(kid);
1789         }
1790         break;
1791     case OP_LEAVE:
1792     case OP_LEAVETRY:
1793         kid = cLISTOPo->op_first;
1794         scalar(kid);
1795         kid = OpSIBLING(kid);
1796     do_kids:
1797         while (kid) {
1798             OP *sib = OpSIBLING(kid);
1799             if (sib && kid->op_type != OP_LEAVEWHEN
1800              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1801                 || (  sib->op_targ != OP_NEXTSTATE
1802                    && sib->op_targ != OP_DBSTATE  )))
1803                 scalarvoid(kid);
1804             else
1805                 scalar(kid);
1806             kid = sib;
1807         }
1808         PL_curcop = &PL_compiling;
1809         break;
1810     case OP_SCOPE:
1811     case OP_LINESEQ:
1812     case OP_LIST:
1813         kid = cLISTOPo->op_first;
1814         goto do_kids;
1815     case OP_SORT:
1816         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1817         break;
1818     case OP_KVHSLICE:
1819     case OP_KVASLICE:
1820     {
1821         /* Warn about scalar context */
1822         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1823         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1824         SV *name;
1825         SV *keysv;
1826         const char *key = NULL;
1827
1828         /* This warning can be nonsensical when there is a syntax error. */
1829         if (PL_parser && PL_parser->error_count)
1830             break;
1831
1832         if (!ckWARN(WARN_SYNTAX)) break;
1833
1834         kid = cLISTOPo->op_first;
1835         kid = OpSIBLING(kid); /* get past pushmark */
1836         assert(OpSIBLING(kid));
1837         name = S_op_varname(aTHX_ OpSIBLING(kid));
1838         if (!name) /* XS module fiddling with the op tree */
1839             break;
1840         S_op_pretty(aTHX_ kid, &keysv, &key);
1841         assert(SvPOK(name));
1842         sv_chop(name,SvPVX(name)+1);
1843         if (key)
1844   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1845             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1846                        "%%%" SVf "%c%s%c in scalar context better written "
1847                        "as $%" SVf "%c%s%c",
1848                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1849                         lbrack, key, rbrack);
1850         else
1851   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1852             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1853                        "%%%" SVf "%c%" SVf "%c in scalar context better "
1854                        "written as $%" SVf "%c%" SVf "%c",
1855                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1856                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1857     }
1858     }
1859     return o;
1860 }
1861
1862 OP *
1863 Perl_scalarvoid(pTHX_ OP *arg)
1864 {
1865     dVAR;
1866     OP *kid;
1867     SV* sv;
1868     SSize_t defer_stack_alloc = 0;
1869     SSize_t defer_ix = -1;
1870     OP **defer_stack = NULL;
1871     OP *o = arg;
1872
1873     PERL_ARGS_ASSERT_SCALARVOID;
1874
1875     do {
1876         U8 want;
1877         SV *useless_sv = NULL;
1878         const char* useless = NULL;
1879
1880         if (o->op_type == OP_NEXTSTATE
1881             || o->op_type == OP_DBSTATE
1882             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1883                                           || o->op_targ == OP_DBSTATE)))
1884             PL_curcop = (COP*)o;                /* for warning below */
1885
1886         /* assumes no premature commitment */
1887         want = o->op_flags & OPf_WANT;
1888         if ((want && want != OPf_WANT_SCALAR)
1889             || (PL_parser && PL_parser->error_count)
1890             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1891         {
1892             continue;
1893         }
1894
1895         if ((o->op_private & OPpTARGET_MY)
1896             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1897         {
1898             /* newASSIGNOP has already applied scalar context, which we
1899                leave, as if this op is inside SASSIGN.  */
1900             continue;
1901         }
1902
1903         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1904
1905         switch (o->op_type) {
1906         default:
1907             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1908                 break;
1909             /* FALLTHROUGH */
1910         case OP_REPEAT:
1911             if (o->op_flags & OPf_STACKED)
1912                 break;
1913             if (o->op_type == OP_REPEAT)
1914                 scalar(cBINOPo->op_first);
1915             goto func_ops;
1916         case OP_SUBSTR:
1917             if (o->op_private == 4)
1918                 break;
1919             /* FALLTHROUGH */
1920         case OP_WANTARRAY:
1921         case OP_GV:
1922         case OP_SMARTMATCH:
1923         case OP_AV2ARYLEN:
1924         case OP_REF:
1925         case OP_REFGEN:
1926         case OP_SREFGEN:
1927         case OP_DEFINED:
1928         case OP_HEX:
1929         case OP_OCT:
1930         case OP_LENGTH:
1931         case OP_VEC:
1932         case OP_INDEX:
1933         case OP_RINDEX:
1934         case OP_SPRINTF:
1935         case OP_KVASLICE:
1936         case OP_KVHSLICE:
1937         case OP_UNPACK:
1938         case OP_PACK:
1939         case OP_JOIN:
1940         case OP_LSLICE:
1941         case OP_ANONLIST:
1942         case OP_ANONHASH:
1943         case OP_SORT:
1944         case OP_REVERSE:
1945         case OP_RANGE:
1946         case OP_FLIP:
1947         case OP_FLOP:
1948         case OP_CALLER:
1949         case OP_FILENO:
1950         case OP_EOF:
1951         case OP_TELL:
1952         case OP_GETSOCKNAME:
1953         case OP_GETPEERNAME:
1954         case OP_READLINK:
1955         case OP_TELLDIR:
1956         case OP_GETPPID:
1957         case OP_GETPGRP:
1958         case OP_GETPRIORITY:
1959         case OP_TIME:
1960         case OP_TMS:
1961         case OP_LOCALTIME:
1962         case OP_GMTIME:
1963         case OP_GHBYNAME:
1964         case OP_GHBYADDR:
1965         case OP_GHOSTENT:
1966         case OP_GNBYNAME:
1967         case OP_GNBYADDR:
1968         case OP_GNETENT:
1969         case OP_GPBYNAME:
1970         case OP_GPBYNUMBER:
1971         case OP_GPROTOENT:
1972         case OP_GSBYNAME:
1973         case OP_GSBYPORT:
1974         case OP_GSERVENT:
1975         case OP_GPWNAM:
1976         case OP_GPWUID:
1977         case OP_GGRNAM:
1978         case OP_GGRGID:
1979         case OP_GETLOGIN:
1980         case OP_PROTOTYPE:
1981         case OP_RUNCV:
1982         func_ops:
1983             useless = OP_DESC(o);
1984             break;
1985
1986         case OP_GVSV:
1987         case OP_PADSV:
1988         case OP_PADAV:
1989         case OP_PADHV:
1990         case OP_PADANY:
1991         case OP_AELEM:
1992         case OP_AELEMFAST:
1993         case OP_AELEMFAST_LEX:
1994         case OP_ASLICE:
1995         case OP_HELEM:
1996         case OP_HSLICE:
1997             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1998                 /* Otherwise it's "Useless use of grep iterator" */
1999                 useless = OP_DESC(o);
2000             break;
2001
2002         case OP_SPLIT:
2003             if (!(o->op_private & OPpSPLIT_ASSIGN))
2004                 useless = OP_DESC(o);
2005             break;
2006
2007         case OP_NOT:
2008             kid = cUNOPo->op_first;
2009             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2010                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2011                 goto func_ops;
2012             }
2013             useless = "negative pattern binding (!~)";
2014             break;
2015
2016         case OP_SUBST:
2017             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2018                 useless = "non-destructive substitution (s///r)";
2019             break;
2020
2021         case OP_TRANSR:
2022             useless = "non-destructive transliteration (tr///r)";
2023             break;
2024
2025         case OP_RV2GV:
2026         case OP_RV2SV:
2027         case OP_RV2AV:
2028         case OP_RV2HV:
2029             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2030                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2031                 useless = "a variable";
2032             break;
2033
2034         case OP_CONST:
2035             sv = cSVOPo_sv;
2036             if (cSVOPo->op_private & OPpCONST_STRICT)
2037                 no_bareword_allowed(o);
2038             else {
2039                 if (ckWARN(WARN_VOID)) {
2040                     NV nv;
2041                     /* don't warn on optimised away booleans, eg
2042                      * use constant Foo, 5; Foo || print; */
2043                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2044                         useless = NULL;
2045                     /* the constants 0 and 1 are permitted as they are
2046                        conventionally used as dummies in constructs like
2047                        1 while some_condition_with_side_effects;  */
2048                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2049                         useless = NULL;
2050                     else if (SvPOK(sv)) {
2051                         SV * const dsv = newSVpvs("");
2052                         useless_sv
2053                             = Perl_newSVpvf(aTHX_
2054                                             "a constant (%s)",
2055                                             pv_pretty(dsv, SvPVX_const(sv),
2056                                                       SvCUR(sv), 32, NULL, NULL,
2057                                                       PERL_PV_PRETTY_DUMP
2058                                                       | PERL_PV_ESCAPE_NOCLEAR
2059                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2060                         SvREFCNT_dec_NN(dsv);
2061                     }
2062                     else if (SvOK(sv)) {
2063                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2064                     }
2065                     else
2066                         useless = "a constant (undef)";
2067                 }
2068             }
2069             op_null(o);         /* don't execute or even remember it */
2070             break;
2071
2072         case OP_POSTINC:
2073             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2074             break;
2075
2076         case OP_POSTDEC:
2077             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2078             break;
2079
2080         case OP_I_POSTINC:
2081             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2082             break;
2083
2084         case OP_I_POSTDEC:
2085             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2086             break;
2087
2088         case OP_SASSIGN: {
2089             OP *rv2gv;
2090             UNOP *refgen, *rv2cv;
2091             LISTOP *exlist;
2092
2093             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2094                 break;
2095
2096             rv2gv = ((BINOP *)o)->op_last;
2097             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2098                 break;
2099
2100             refgen = (UNOP *)((BINOP *)o)->op_first;
2101
2102             if (!refgen || (refgen->op_type != OP_REFGEN
2103                             && refgen->op_type != OP_SREFGEN))
2104                 break;
2105
2106             exlist = (LISTOP *)refgen->op_first;
2107             if (!exlist || exlist->op_type != OP_NULL
2108                 || exlist->op_targ != OP_LIST)
2109                 break;
2110
2111             if (exlist->op_first->op_type != OP_PUSHMARK
2112                 && exlist->op_first != exlist->op_last)
2113                 break;
2114
2115             rv2cv = (UNOP*)exlist->op_last;
2116
2117             if (rv2cv->op_type != OP_RV2CV)
2118                 break;
2119
2120             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2121             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2122             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2123
2124             o->op_private |= OPpASSIGN_CV_TO_GV;
2125             rv2gv->op_private |= OPpDONT_INIT_GV;
2126             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2127
2128             break;
2129         }
2130
2131         case OP_AASSIGN: {
2132             inplace_aassign(o);
2133             break;
2134         }
2135
2136         case OP_OR:
2137         case OP_AND:
2138             kid = cLOGOPo->op_first;
2139             if (kid->op_type == OP_NOT
2140                 && (kid->op_flags & OPf_KIDS)) {
2141                 if (o->op_type == OP_AND) {
2142                     OpTYPE_set(o, OP_OR);
2143                 } else {
2144                     OpTYPE_set(o, OP_AND);
2145                 }
2146                 op_null(kid);
2147             }
2148             /* FALLTHROUGH */
2149
2150         case OP_DOR:
2151         case OP_COND_EXPR:
2152         case OP_ENTERGIVEN:
2153         case OP_ENTERWHEN:
2154             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2155                 if (!(kid->op_flags & OPf_KIDS))
2156                     scalarvoid(kid);
2157                 else
2158                     DEFER_OP(kid);
2159         break;
2160
2161         case OP_NULL:
2162             if (o->op_flags & OPf_STACKED)
2163                 break;
2164             /* FALLTHROUGH */
2165         case OP_NEXTSTATE:
2166         case OP_DBSTATE:
2167         case OP_ENTERTRY:
2168         case OP_ENTER:
2169             if (!(o->op_flags & OPf_KIDS))
2170                 break;
2171             /* FALLTHROUGH */
2172         case OP_SCOPE:
2173         case OP_LEAVE:
2174         case OP_LEAVETRY:
2175         case OP_LEAVELOOP:
2176         case OP_LINESEQ:
2177         case OP_LEAVEGIVEN:
2178         case OP_LEAVEWHEN:
2179         kids:
2180             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2181                 if (!(kid->op_flags & OPf_KIDS))
2182                     scalarvoid(kid);
2183                 else
2184                     DEFER_OP(kid);
2185             break;
2186         case OP_LIST:
2187             /* If the first kid after pushmark is something that the padrange
2188                optimisation would reject, then null the list and the pushmark.
2189             */
2190             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2191                 && (  !(kid = OpSIBLING(kid))
2192                       || (  kid->op_type != OP_PADSV
2193                             && kid->op_type != OP_PADAV
2194                             && kid->op_type != OP_PADHV)
2195                       || kid->op_private & ~OPpLVAL_INTRO
2196                       || !(kid = OpSIBLING(kid))
2197                       || (  kid->op_type != OP_PADSV
2198                             && kid->op_type != OP_PADAV
2199                             && kid->op_type != OP_PADHV)
2200                       || kid->op_private & ~OPpLVAL_INTRO)
2201             ) {
2202                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2203                 op_null(o); /* NULL the list */
2204             }
2205             goto kids;
2206         case OP_ENTEREVAL:
2207             scalarkids(o);
2208             break;
2209         case OP_SCALAR:
2210             scalar(o);
2211             break;
2212         }
2213
2214         if (useless_sv) {
2215             /* mortalise it, in case warnings are fatal.  */
2216             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2217                            "Useless use of %" SVf " in void context",
2218                            SVfARG(sv_2mortal(useless_sv)));
2219         }
2220         else if (useless) {
2221             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2222                            "Useless use of %s in void context",
2223                            useless);
2224         }
2225     } while ( (o = POP_DEFERRED_OP()) );
2226
2227     Safefree(defer_stack);
2228
2229     return arg;
2230 }
2231
2232 static OP *
2233 S_listkids(pTHX_ OP *o)
2234 {
2235     if (o && o->op_flags & OPf_KIDS) {
2236         OP *kid;
2237         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2238             list(kid);
2239     }
2240     return o;
2241 }
2242
2243 OP *
2244 Perl_list(pTHX_ OP *o)
2245 {
2246     OP *kid;
2247
2248     /* assumes no premature commitment */
2249     if (!o || (o->op_flags & OPf_WANT)
2250          || (PL_parser && PL_parser->error_count)
2251          || o->op_type == OP_RETURN)
2252     {
2253         return o;
2254     }
2255
2256     if ((o->op_private & OPpTARGET_MY)
2257         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2258     {
2259         return o;                               /* As if inside SASSIGN */
2260     }
2261
2262     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2263
2264     switch (o->op_type) {
2265     case OP_FLOP:
2266         list(cBINOPo->op_first);
2267         break;
2268     case OP_REPEAT:
2269         if (o->op_private & OPpREPEAT_DOLIST
2270          && !(o->op_flags & OPf_STACKED))
2271         {
2272             list(cBINOPo->op_first);
2273             kid = cBINOPo->op_last;
2274             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2275              && SvIVX(kSVOP_sv) == 1)
2276             {
2277                 op_null(o); /* repeat */
2278                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2279                 /* const (rhs): */
2280                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2281             }
2282         }
2283         break;
2284     case OP_OR:
2285     case OP_AND:
2286     case OP_COND_EXPR:
2287         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2288             list(kid);
2289         break;
2290     default:
2291     case OP_MATCH:
2292     case OP_QR:
2293     case OP_SUBST:
2294     case OP_NULL:
2295         if (!(o->op_flags & OPf_KIDS))
2296             break;
2297         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2298             list(cBINOPo->op_first);
2299             return gen_constant_list(o);
2300         }
2301         listkids(o);
2302         break;
2303     case OP_LIST:
2304         listkids(o);
2305         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2306             op_null(cUNOPo->op_first); /* NULL the pushmark */
2307             op_null(o); /* NULL the list */
2308         }
2309         break;
2310     case OP_LEAVE:
2311     case OP_LEAVETRY:
2312         kid = cLISTOPo->op_first;
2313         list(kid);
2314         kid = OpSIBLING(kid);
2315     do_kids:
2316         while (kid) {
2317             OP *sib = OpSIBLING(kid);
2318             if (sib && kid->op_type != OP_LEAVEWHEN)
2319                 scalarvoid(kid);
2320             else
2321                 list(kid);
2322             kid = sib;
2323         }
2324         PL_curcop = &PL_compiling;
2325         break;
2326     case OP_SCOPE:
2327     case OP_LINESEQ:
2328         kid = cLISTOPo->op_first;
2329         goto do_kids;
2330     }
2331     return o;
2332 }
2333
2334 static OP *
2335 S_scalarseq(pTHX_ OP *o)
2336 {
2337     if (o) {
2338         const OPCODE type = o->op_type;
2339
2340         if (type == OP_LINESEQ || type == OP_SCOPE ||
2341             type == OP_LEAVE || type == OP_LEAVETRY)
2342         {
2343             OP *kid, *sib;
2344             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2345                 if ((sib = OpSIBLING(kid))
2346                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2347                     || (  sib->op_targ != OP_NEXTSTATE
2348                        && sib->op_targ != OP_DBSTATE  )))
2349                 {
2350                     scalarvoid(kid);
2351                 }
2352             }
2353             PL_curcop = &PL_compiling;
2354         }
2355         o->op_flags &= ~OPf_PARENS;
2356         if (PL_hints & HINT_BLOCK_SCOPE)
2357             o->op_flags |= OPf_PARENS;
2358     }
2359     else
2360         o = newOP(OP_STUB, 0);
2361     return o;
2362 }
2363
2364 STATIC OP *
2365 S_modkids(pTHX_ OP *o, I32 type)
2366 {
2367     if (o && o->op_flags & OPf_KIDS) {
2368         OP *kid;
2369         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2370             op_lvalue(kid, type);
2371     }
2372     return o;
2373 }
2374
2375
2376 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2377  * const fields. Also, convert CONST keys to HEK-in-SVs.
2378  * rop is the op that retrieves the hash;
2379  * key_op is the first key
2380  */
2381
2382 STATIC void
2383 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2384 {
2385     PADNAME *lexname;
2386     GV **fields;
2387     bool check_fields;
2388
2389     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2390     if (rop) {
2391         if (rop->op_first->op_type == OP_PADSV)
2392             /* @$hash{qw(keys here)} */
2393             rop = (UNOP*)rop->op_first;
2394         else {
2395             /* @{$hash}{qw(keys here)} */
2396             if (rop->op_first->op_type == OP_SCOPE
2397                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2398                 {
2399                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2400                 }
2401             else
2402                 rop = NULL;
2403         }
2404     }
2405
2406     lexname = NULL; /* just to silence compiler warnings */
2407     fields  = NULL; /* just to silence compiler warnings */
2408
2409     check_fields =
2410             rop
2411          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2412              SvPAD_TYPED(lexname))
2413          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2414          && isGV(*fields) && GvHV(*fields);
2415
2416     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2417         SV **svp, *sv;
2418         if (key_op->op_type != OP_CONST)
2419             continue;
2420         svp = cSVOPx_svp(key_op);
2421
2422         /* make sure it's not a bareword under strict subs */
2423         if (key_op->op_private & OPpCONST_BARE &&
2424             key_op->op_private & OPpCONST_STRICT)
2425         {
2426             no_bareword_allowed((OP*)key_op);
2427         }
2428
2429         /* Make the CONST have a shared SV */
2430         if (   !SvIsCOW_shared_hash(sv = *svp)
2431             && SvTYPE(sv) < SVt_PVMG
2432             && SvOK(sv)
2433             && !SvROK(sv))
2434         {
2435             SSize_t keylen;
2436             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2437             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2438             SvREFCNT_dec_NN(sv);
2439             *svp = nsv;
2440         }
2441
2442         if (   check_fields
2443             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2444         {
2445             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2446                         "in variable %" PNf " of type %" HEKf,
2447                         SVfARG(*svp), PNfARG(lexname),
2448                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2449         }
2450     }
2451 }
2452
2453
2454 /* do all the final processing on an optree (e.g. running the peephole
2455  * optimiser on it), then attach it to cv (if cv is non-null)
2456  */
2457
2458 static void
2459 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2460 {
2461     OP **startp;
2462
2463     /* XXX for some reason, evals, require and main optrees are
2464      * never attached to their CV; instead they just hang off
2465      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2466      * and get manually freed when appropriate */
2467     if (cv)
2468         startp = &CvSTART(cv);
2469     else
2470         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2471
2472     *startp = start;
2473     optree->op_private |= OPpREFCOUNTED;
2474     OpREFCNT_set(optree, 1);
2475     CALL_PEEP(*startp);
2476     finalize_optree(optree);
2477     S_prune_chain_head(startp);
2478
2479     if (cv) {
2480         /* now that optimizer has done its work, adjust pad values */
2481         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2482                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2483     }
2484 }
2485
2486
2487 /*
2488 =for apidoc finalize_optree
2489
2490 This function finalizes the optree.  Should be called directly after
2491 the complete optree is built.  It does some additional
2492 checking which can't be done in the normal C<ck_>xxx functions and makes
2493 the tree thread-safe.
2494
2495 =cut
2496 */
2497 void
2498 Perl_finalize_optree(pTHX_ OP* o)
2499 {
2500     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2501
2502     ENTER;
2503     SAVEVPTR(PL_curcop);
2504
2505     finalize_op(o);
2506
2507     LEAVE;
2508 }
2509
2510 #ifdef USE_ITHREADS
2511 /* Relocate sv to the pad for thread safety.
2512  * Despite being a "constant", the SV is written to,
2513  * for reference counts, sv_upgrade() etc. */
2514 PERL_STATIC_INLINE void
2515 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2516 {
2517     PADOFFSET ix;
2518     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2519     if (!*svp) return;
2520     ix = pad_alloc(OP_CONST, SVf_READONLY);
2521     SvREFCNT_dec(PAD_SVl(ix));
2522     PAD_SETSV(ix, *svp);
2523     /* XXX I don't know how this isn't readonly already. */
2524     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2525     *svp = NULL;
2526     *targp = ix;
2527 }
2528 #endif
2529
2530
2531 STATIC void
2532 S_finalize_op(pTHX_ OP* o)
2533 {
2534     PERL_ARGS_ASSERT_FINALIZE_OP;
2535
2536     assert(o->op_type != OP_FREED);
2537
2538     switch (o->op_type) {
2539     case OP_NEXTSTATE:
2540     case OP_DBSTATE:
2541         PL_curcop = ((COP*)o);          /* for warnings */
2542         break;
2543     case OP_EXEC:
2544         if (OpHAS_SIBLING(o)) {
2545             OP *sib = OpSIBLING(o);
2546             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2547                 && ckWARN(WARN_EXEC)
2548                 && OpHAS_SIBLING(sib))
2549             {
2550                     const OPCODE type = OpSIBLING(sib)->op_type;
2551                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2552                         const line_t oldline = CopLINE(PL_curcop);
2553                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2554                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2555                             "Statement unlikely to be reached");
2556                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2557                             "\t(Maybe you meant system() when you said exec()?)\n");
2558                         CopLINE_set(PL_curcop, oldline);
2559                     }
2560             }
2561         }
2562         break;
2563
2564     case OP_GV:
2565         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2566             GV * const gv = cGVOPo_gv;
2567             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2568                 /* XXX could check prototype here instead of just carping */
2569                 SV * const sv = sv_newmortal();
2570                 gv_efullname3(sv, gv, NULL);
2571                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2572                     "%" SVf "() called too early to check prototype",
2573                     SVfARG(sv));
2574             }
2575         }
2576         break;
2577
2578     case OP_CONST:
2579         if (cSVOPo->op_private & OPpCONST_STRICT)
2580             no_bareword_allowed(o);
2581         /* FALLTHROUGH */
2582 #ifdef USE_ITHREADS
2583     case OP_HINTSEVAL:
2584         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2585 #endif
2586         break;
2587
2588 #ifdef USE_ITHREADS
2589     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2590     case OP_METHOD_NAMED:
2591     case OP_METHOD_SUPER:
2592     case OP_METHOD_REDIR:
2593     case OP_METHOD_REDIR_SUPER:
2594         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2595         break;
2596 #endif
2597
2598     case OP_HELEM: {
2599         UNOP *rop;
2600         SVOP *key_op;
2601         OP *kid;
2602
2603         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2604             break;
2605
2606         rop = (UNOP*)((BINOP*)o)->op_first;
2607
2608         goto check_keys;
2609
2610     case OP_HSLICE:
2611         S_scalar_slice_warning(aTHX_ o);
2612         /* FALLTHROUGH */
2613
2614     case OP_KVHSLICE:
2615         kid = OpSIBLING(cLISTOPo->op_first);
2616         if (/* I bet there's always a pushmark... */
2617             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2618             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2619         {
2620             break;
2621         }
2622
2623         key_op = (SVOP*)(kid->op_type == OP_CONST
2624                                 ? kid
2625                                 : OpSIBLING(kLISTOP->op_first));
2626
2627         rop = (UNOP*)((LISTOP*)o)->op_last;
2628
2629       check_keys:       
2630         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2631             rop = NULL;
2632         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2633         break;
2634     }
2635     case OP_NULL:
2636         if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
2637             break;
2638         /* FALLTHROUGH */
2639     case OP_ASLICE:
2640         S_scalar_slice_warning(aTHX_ o);
2641         break;
2642
2643     case OP_SUBST: {
2644         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2645             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2646         break;
2647     }
2648     default:
2649         break;
2650     }
2651
2652     if (o->op_flags & OPf_KIDS) {
2653         OP *kid;
2654
2655 #ifdef DEBUGGING
2656         /* check that op_last points to the last sibling, and that
2657          * the last op_sibling/op_sibparent field points back to the
2658          * parent, and that the only ops with KIDS are those which are
2659          * entitled to them */
2660         U32 type = o->op_type;
2661         U32 family;
2662         bool has_last;
2663
2664         if (type == OP_NULL) {
2665             type = o->op_targ;
2666             /* ck_glob creates a null UNOP with ex-type GLOB
2667              * (which is a list op. So pretend it wasn't a listop */
2668             if (type == OP_GLOB)
2669                 type = OP_NULL;
2670         }
2671         family = PL_opargs[type] & OA_CLASS_MASK;
2672
2673         has_last = (   family == OA_BINOP
2674                     || family == OA_LISTOP
2675                     || family == OA_PMOP
2676                     || family == OA_LOOP
2677                    );
2678         assert(  has_last /* has op_first and op_last, or ...
2679               ... has (or may have) op_first: */
2680               || family == OA_UNOP
2681               || family == OA_UNOP_AUX
2682               || family == OA_LOGOP
2683               || family == OA_BASEOP_OR_UNOP
2684               || family == OA_FILESTATOP
2685               || family == OA_LOOPEXOP
2686               || family == OA_METHOP
2687               || type == OP_CUSTOM
2688               || type == OP_NULL /* new_logop does this */
2689               );
2690
2691         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2692 #  ifdef PERL_OP_PARENT
2693             if (!OpHAS_SIBLING(kid)) {
2694                 if (has_last)
2695                     assert(kid == cLISTOPo->op_last);
2696                 assert(kid->op_sibparent == o);
2697             }
2698 #  else
2699             if (has_last && !OpHAS_SIBLING(kid))
2700                 assert(kid == cLISTOPo->op_last);
2701 #  endif
2702         }
2703 #endif
2704
2705         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2706             finalize_op(kid);
2707     }
2708 }
2709
2710 /*
2711 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2712
2713 Propagate lvalue ("modifiable") context to an op and its children.
2714 C<type> represents the context type, roughly based on the type of op that
2715 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2716 because it has no op type of its own (it is signalled by a flag on
2717 the lvalue op).
2718
2719 This function detects things that can't be modified, such as C<$x+1>, and
2720 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2721 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2722
2723 It also flags things that need to behave specially in an lvalue context,
2724 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2725
2726 =cut
2727 */
2728
2729 static void
2730 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2731 {
2732     CV *cv = PL_compcv;
2733     PadnameLVALUE_on(pn);
2734     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2735         cv = CvOUTSIDE(cv);
2736         /* RT #127786: cv can be NULL due to an eval within the DB package
2737          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2738          * unless they contain an eval, but calling eval within DB
2739          * pretends the eval was done in the caller's scope.
2740          */
2741         if (!cv)
2742             break;
2743         assert(CvPADLIST(cv));
2744         pn =
2745            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2746         assert(PadnameLEN(pn));
2747         PadnameLVALUE_on(pn);
2748     }
2749 }
2750
2751 static bool
2752 S_vivifies(const OPCODE type)
2753 {
2754     switch(type) {
2755     case OP_RV2AV:     case   OP_ASLICE:
2756     case OP_RV2HV:     case OP_KVASLICE:
2757     case OP_RV2SV:     case   OP_HSLICE:
2758     case OP_AELEMFAST: case OP_KVHSLICE:
2759     case OP_HELEM:
2760     case OP_AELEM:
2761         return 1;
2762     }
2763     return 0;
2764 }
2765
2766 static void
2767 S_lvref(pTHX_ OP *o, I32 type)
2768 {
2769     dVAR;
2770     OP *kid;
2771     switch (o->op_type) {
2772     case OP_COND_EXPR:
2773         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2774              kid = OpSIBLING(kid))
2775             S_lvref(aTHX_ kid, type);
2776         /* FALLTHROUGH */
2777     case OP_PUSHMARK:
2778         return;
2779     case OP_RV2AV:
2780         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2781         o->op_flags |= OPf_STACKED;
2782         if (o->op_flags & OPf_PARENS) {
2783             if (o->op_private & OPpLVAL_INTRO) {
2784                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2785                       "localized parenthesized array in list assignment"));
2786                 return;
2787             }
2788           slurpy:
2789             OpTYPE_set(o, OP_LVAVREF);
2790             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2791             o->op_flags |= OPf_MOD|OPf_REF;
2792             return;
2793         }
2794         o->op_private |= OPpLVREF_AV;
2795         goto checkgv;
2796     case OP_RV2CV:
2797         kid = cUNOPo->op_first;
2798         if (kid->op_type == OP_NULL)
2799             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2800                 ->op_first;
2801         o->op_private = OPpLVREF_CV;
2802         if (kid->op_type == OP_GV)
2803             o->op_flags |= OPf_STACKED;
2804         else if (kid->op_type == OP_PADCV) {
2805             o->op_targ = kid->op_targ;
2806             kid->op_targ = 0;
2807             op_free(cUNOPo->op_first);
2808             cUNOPo->op_first = NULL;
2809             o->op_flags &=~ OPf_KIDS;
2810         }
2811         else goto badref;
2812         break;
2813     case OP_RV2HV:
2814         if (o->op_flags & OPf_PARENS) {
2815           parenhash:
2816             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2817                                  "parenthesized hash in list assignment"));
2818                 return;
2819         }
2820         o->op_private |= OPpLVREF_HV;
2821         /* FALLTHROUGH */
2822     case OP_RV2SV:
2823       checkgv:
2824         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2825         o->op_flags |= OPf_STACKED;
2826         break;
2827     case OP_PADHV:
2828         if (o->op_flags & OPf_PARENS) goto parenhash;
2829         o->op_private |= OPpLVREF_HV;
2830         /* FALLTHROUGH */
2831     case OP_PADSV:
2832         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2833         break;
2834     case OP_PADAV:
2835         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2836         if (o->op_flags & OPf_PARENS) goto slurpy;
2837         o->op_private |= OPpLVREF_AV;
2838         break;
2839     case OP_AELEM:
2840     case OP_HELEM:
2841         o->op_private |= OPpLVREF_ELEM;
2842         o->op_flags   |= OPf_STACKED;
2843         break;
2844     case OP_ASLICE:
2845     case OP_HSLICE:
2846         OpTYPE_set(o, OP_LVREFSLICE);
2847         o->op_private &= OPpLVAL_INTRO;
2848         return;
2849     case OP_NULL:
2850         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2851             goto badref;
2852         else if (!(o->op_flags & OPf_KIDS))
2853             return;
2854         if (o->op_targ != OP_LIST) {
2855             S_lvref(aTHX_ cBINOPo->op_first, type);
2856             return;
2857         }
2858         /* FALLTHROUGH */
2859     case OP_LIST:
2860         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2861             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2862             S_lvref(aTHX_ kid, type);
2863         }
2864         return;
2865     case OP_STUB:
2866         if (o->op_flags & OPf_PARENS)
2867             return;
2868         /* FALLTHROUGH */
2869     default:
2870       badref:
2871         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2872         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2873                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2874                       ? "do block"
2875                       : OP_DESC(o),
2876                      PL_op_desc[type]));
2877         return;
2878     }
2879     OpTYPE_set(o, OP_LVREF);
2880     o->op_private &=
2881         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2882     if (type == OP_ENTERLOOP)
2883         o->op_private |= OPpLVREF_ITER;
2884 }
2885
2886 PERL_STATIC_INLINE bool
2887 S_potential_mod_type(I32 type)
2888 {
2889     /* Types that only potentially result in modification.  */
2890     return type == OP_GREPSTART || type == OP_ENTERSUB
2891         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2892 }
2893
2894 OP *
2895 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2896 {
2897     dVAR;
2898     OP *kid;
2899     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2900     int localize = -1;
2901
2902     if (!o || (PL_parser && PL_parser->error_count))
2903         return o;
2904
2905     if ((o->op_private & OPpTARGET_MY)
2906         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2907     {
2908         return o;
2909     }
2910
2911     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2912
2913     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2914
2915     switch (o->op_type) {
2916     case OP_UNDEF:
2917         PL_modcount++;
2918         return o;
2919     case OP_STUB:
2920         if ((o->op_flags & OPf_PARENS))
2921             break;
2922         goto nomod;
2923     case OP_ENTERSUB:
2924         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2925             !(o->op_flags & OPf_STACKED)) {
2926             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2927             assert(cUNOPo->op_first->op_type == OP_NULL);
2928             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2929             break;
2930         }
2931         else {                          /* lvalue subroutine call */
2932             o->op_private |= OPpLVAL_INTRO;
2933             PL_modcount = RETURN_UNLIMITED_NUMBER;
2934             if (S_potential_mod_type(type)) {
2935                 o->op_private |= OPpENTERSUB_INARGS;
2936                 break;
2937             }
2938             else {                      /* Compile-time error message: */
2939                 OP *kid = cUNOPo->op_first;
2940                 CV *cv;
2941                 GV *gv;
2942                 SV *namesv;
2943
2944                 if (kid->op_type != OP_PUSHMARK) {
2945                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2946                         Perl_croak(aTHX_
2947                                 "panic: unexpected lvalue entersub "
2948                                 "args: type/targ %ld:%" UVuf,
2949                                 (long)kid->op_type, (UV)kid->op_targ);
2950                     kid = kLISTOP->op_first;
2951                 }
2952                 while (OpHAS_SIBLING(kid))
2953                     kid = OpSIBLING(kid);
2954                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2955                     break;      /* Postpone until runtime */
2956                 }
2957
2958                 kid = kUNOP->op_first;
2959                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2960                     kid = kUNOP->op_first;
2961                 if (kid->op_type == OP_NULL)
2962                     Perl_croak(aTHX_
2963                                "Unexpected constant lvalue entersub "
2964                                "entry via type/targ %ld:%" UVuf,
2965                                (long)kid->op_type, (UV)kid->op_targ);
2966                 if (kid->op_type != OP_GV) {
2967                     break;
2968                 }
2969
2970                 gv = kGVOP_gv;
2971                 cv = isGV(gv)
2972                     ? GvCV(gv)
2973                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2974                         ? MUTABLE_CV(SvRV(gv))
2975                         : NULL;
2976                 if (!cv)
2977                     break;
2978                 if (CvLVALUE(cv))
2979                     break;
2980                 if (flags & OP_LVALUE_NO_CROAK)
2981                     return NULL;
2982
2983                 namesv = cv_name(cv, NULL, 0);
2984                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2985                                      "subroutine call of &%" SVf " in %s",
2986                                      SVfARG(namesv), PL_op_desc[type]),
2987                            SvUTF8(namesv));
2988                 return o;
2989             }
2990         }
2991         /* FALLTHROUGH */
2992     default:
2993       nomod:
2994         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2995         /* grep, foreach, subcalls, refgen */
2996         if (S_potential_mod_type(type))
2997             break;
2998         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2999                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3000                       ? "do block"
3001                       : OP_DESC(o)),
3002                      type ? PL_op_desc[type] : "local"));
3003         return o;
3004
3005     case OP_PREINC:
3006     case OP_PREDEC:
3007     case OP_POW:
3008     case OP_MULTIPLY:
3009     case OP_DIVIDE:
3010     case OP_MODULO:
3011     case OP_ADD:
3012     case OP_SUBTRACT:
3013     case OP_CONCAT:
3014     case OP_LEFT_SHIFT:
3015     case OP_RIGHT_SHIFT:
3016     case OP_BIT_AND:
3017     case OP_BIT_XOR:
3018     case OP_BIT_OR:
3019     case OP_I_MULTIPLY:
3020     case OP_I_DIVIDE:
3021     case OP_I_MODULO:
3022     case OP_I_ADD:
3023     case OP_I_SUBTRACT:
3024         if (!(o->op_flags & OPf_STACKED))
3025             goto nomod;
3026         PL_modcount++;
3027         break;
3028
3029     case OP_REPEAT:
3030         if (o->op_flags & OPf_STACKED) {
3031             PL_modcount++;
3032             break;
3033         }
3034         if (!(o->op_private & OPpREPEAT_DOLIST))
3035             goto nomod;
3036         else {
3037             const I32 mods = PL_modcount;
3038             modkids(cBINOPo->op_first, type);
3039             if (type != OP_AASSIGN)
3040                 goto nomod;
3041             kid = cBINOPo->op_last;
3042             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3043                 const IV iv = SvIV(kSVOP_sv);
3044                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3045                     PL_modcount =
3046                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3047             }
3048             else
3049                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3050         }
3051         break;
3052
3053     case OP_COND_EXPR:
3054         localize = 1;
3055         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3056             op_lvalue(kid, type);
3057         break;
3058
3059     case OP_RV2AV:
3060     case OP_RV2HV:
3061         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3062            PL_modcount = RETURN_UNLIMITED_NUMBER;
3063             return o;           /* Treat \(@foo) like ordinary list. */
3064         }
3065         /* FALLTHROUGH */
3066     case OP_RV2GV:
3067         if (scalar_mod_type(o, type))
3068             goto nomod;
3069         ref(cUNOPo->op_first, o->op_type);
3070         /* FALLTHROUGH */
3071     case OP_ASLICE:
3072     case OP_HSLICE:
3073         localize = 1;
3074         /* FALLTHROUGH */
3075     case OP_AASSIGN:
3076         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3077         if (type == OP_LEAVESUBLV && (
3078                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3079              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3080            ))
3081             o->op_private |= OPpMAYBE_LVSUB;
3082         /* FALLTHROUGH */
3083     case OP_NEXTSTATE:
3084     case OP_DBSTATE:
3085        PL_modcount = RETURN_UNLIMITED_NUMBER;
3086         break;
3087     case OP_KVHSLICE:
3088     case OP_KVASLICE:
3089     case OP_AKEYS:
3090         if (type == OP_LEAVESUBLV)
3091             o->op_private |= OPpMAYBE_LVSUB;
3092         goto nomod;
3093     case OP_AVHVSWITCH:
3094         if (type == OP_LEAVESUBLV
3095          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3096             o->op_private |= OPpMAYBE_LVSUB;
3097         goto nomod;
3098     case OP_AV2ARYLEN:
3099         PL_hints |= HINT_BLOCK_SCOPE;
3100         if (type == OP_LEAVESUBLV)
3101             o->op_private |= OPpMAYBE_LVSUB;
3102         PL_modcount++;
3103         break;
3104     case OP_RV2SV:
3105         ref(cUNOPo->op_first, o->op_type);
3106         localize = 1;
3107         /* FALLTHROUGH */
3108     case OP_GV:
3109         PL_hints |= HINT_BLOCK_SCOPE;
3110         /* FALLTHROUGH */
3111     case OP_SASSIGN:
3112     case OP_ANDASSIGN:
3113     case OP_ORASSIGN:
3114     case OP_DORASSIGN:
3115         PL_modcount++;
3116         break;
3117
3118     case OP_AELEMFAST:
3119     case OP_AELEMFAST_LEX:
3120         localize = -1;
3121         PL_modcount++;
3122         break;
3123
3124     case OP_PADAV:
3125     case OP_PADHV:
3126        PL_modcount = RETURN_UNLIMITED_NUMBER;
3127         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3128             return o;           /* Treat \(@foo) like ordinary list. */
3129         if (scalar_mod_type(o, type))
3130             goto nomod;
3131         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3132           && type == OP_LEAVESUBLV)
3133             o->op_private |= OPpMAYBE_LVSUB;
3134         /* FALLTHROUGH */
3135     case OP_PADSV:
3136         PL_modcount++;
3137         if (!type) /* local() */
3138             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3139                               PNfARG(PAD_COMPNAME(o->op_targ)));
3140         if (!(o->op_private & OPpLVAL_INTRO)
3141          || (  type != OP_SASSIGN && type != OP_AASSIGN
3142             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3143             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3144         break;
3145
3146     case OP_PUSHMARK:
3147         localize = 0;
3148         break;
3149
3150     case OP_KEYS:
3151         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3152             goto nomod;
3153         goto lvalue_func;
3154     case OP_SUBSTR:
3155         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3156             goto nomod;
3157         /* FALLTHROUGH */
3158     case OP_POS:
3159     case OP_VEC:
3160       lvalue_func:
3161         if (type == OP_LEAVESUBLV)
3162             o->op_private |= OPpMAYBE_LVSUB;
3163         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3164             /* substr and vec */
3165             /* If this op is in merely potential (non-fatal) modifiable
3166                context, then apply OP_ENTERSUB context to
3167                the kid op (to avoid croaking).  Other-
3168                wise pass this op’s own type so the correct op is mentioned
3169                in error messages.  */
3170             op_lvalue(OpSIBLING(cBINOPo->op_first),
3171                       S_potential_mod_type(type)
3172                         ? (I32)OP_ENTERSUB
3173                         : o->op_type);
3174         }
3175         break;
3176
3177     case OP_AELEM:
3178     case OP_HELEM:
3179         ref(cBINOPo->op_first, o->op_type);
3180         if (type == OP_ENTERSUB &&
3181              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3182             o->op_private |= OPpLVAL_DEFER;
3183         if (type == OP_LEAVESUBLV)
3184             o->op_private |= OPpMAYBE_LVSUB;
3185         localize = 1;
3186         PL_modcount++;
3187         break;
3188
3189     case OP_LEAVE:
3190     case OP_LEAVELOOP:
3191         o->op_private |= OPpLVALUE;
3192         /* FALLTHROUGH */
3193     case OP_SCOPE:
3194     case OP_ENTER:
3195     case OP_LINESEQ:
3196         localize = 0;
3197         if (o->op_flags & OPf_KIDS)
3198             op_lvalue(cLISTOPo->op_last, type);
3199         break;
3200
3201     case OP_NULL:
3202         localize = 0;
3203         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3204             goto nomod;
3205         else if (!(o->op_flags & OPf_KIDS))
3206             break;
3207
3208         if (o->op_targ != OP_LIST) {
3209             OP *sib = OpSIBLING(cLISTOPo->op_first);
3210             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3211              * that looks like
3212              *
3213              *   null
3214              *      arg
3215              *      trans
3216              *
3217              * compared with things like OP_MATCH which have the argument
3218              * as a child:
3219              *
3220              *   match
3221              *      arg
3222              *
3223              * so handle specially to correctly get "Can't modify" croaks etc
3224              */
3225
3226             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3227             {
3228                 /* this should trigger a "Can't modify transliteration" err */
3229                 op_lvalue(sib, type);
3230             }
3231             op_lvalue(cBINOPo->op_first, type);
3232             break;
3233         }
3234         /* FALLTHROUGH */
3235     case OP_LIST:
3236         localize = 0;
3237         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3238             /* elements might be in void context because the list is
3239                in scalar context or because they are attribute sub calls */
3240             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3241                 op_lvalue(kid, type);
3242         break;
3243
3244     case OP_COREARGS:
3245         return o;
3246
3247     case OP_AND:
3248     case OP_OR:
3249         if (type == OP_LEAVESUBLV
3250          || !S_vivifies(cLOGOPo->op_first->op_type))
3251             op_lvalue(cLOGOPo->op_first, type);
3252         if (type == OP_LEAVESUBLV
3253          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3254             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3255         goto nomod;
3256
3257     case OP_SREFGEN:
3258         if (type == OP_NULL) { /* local */
3259           local_refgen:
3260             if (!FEATURE_MYREF_IS_ENABLED)
3261                 Perl_croak(aTHX_ "The experimental declared_refs "
3262                                  "feature is not enabled");
3263             Perl_ck_warner_d(aTHX_
3264                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3265                     "Declaring references is experimental");
3266             op_lvalue(cUNOPo->op_first, OP_NULL);
3267             return o;
3268         }
3269         if (type != OP_AASSIGN && type != OP_SASSIGN
3270          && type != OP_ENTERLOOP)
3271             goto nomod;
3272         /* Don’t bother applying lvalue context to the ex-list.  */
3273         kid = cUNOPx(cUNOPo->op_first)->op_first;
3274         assert (!OpHAS_SIBLING(kid));
3275         goto kid_2lvref;
3276     case OP_REFGEN:
3277         if (type == OP_NULL) /* local */
3278             goto local_refgen;
3279         if (type != OP_AASSIGN) goto nomod;
3280         kid = cUNOPo->op_first;
3281       kid_2lvref:
3282         {
3283             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3284             S_lvref(aTHX_ kid, type);
3285             if (!PL_parser || PL_parser->error_count == ec) {
3286                 if (!FEATURE_REFALIASING_IS_ENABLED)
3287                     Perl_croak(aTHX_
3288                        "Experimental aliasing via reference not enabled");
3289                 Perl_ck_warner_d(aTHX_
3290                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3291                                 "Aliasing via reference is experimental");
3292             }
3293         }
3294         if (o->op_type == OP_REFGEN)
3295             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3296         op_null(o);
3297         return o;
3298
3299     case OP_SPLIT:
3300         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3301             /* This is actually @array = split.  */
3302             PL_modcount = RETURN_UNLIMITED_NUMBER;
3303             break;
3304         }
3305         goto nomod;
3306
3307     case OP_SCALAR:
3308         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3309         goto nomod;
3310     }
3311
3312     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3313        their argument is a filehandle; thus \stat(".") should not set
3314        it. AMS 20011102 */
3315     if (type == OP_REFGEN &&
3316         PL_check[o->op_type] == Perl_ck_ftst)
3317         return o;
3318
3319     if (type != OP_LEAVESUBLV)
3320         o->op_flags |= OPf_MOD;
3321
3322     if (type == OP_AASSIGN || type == OP_SASSIGN)
3323         o->op_flags |= OPf_SPECIAL
3324                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3325     else if (!type) { /* local() */
3326         switch (localize) {
3327         case 1:
3328             o->op_private |= OPpLVAL_INTRO;
3329             o->op_flags &= ~OPf_SPECIAL;
3330             PL_hints |= HINT_BLOCK_SCOPE;
3331             break;
3332         case 0:
3333             break;
3334         case -1:
3335             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3336                            "Useless localization of %s", OP_DESC(o));
3337         }
3338     }
3339     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3340              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3341         o->op_flags |= OPf_REF;
3342     return o;
3343 }
3344
3345 STATIC bool
3346 S_scalar_mod_type(const OP *o, I32 type)
3347 {
3348     switch (type) {
3349     case OP_POS:
3350     case OP_SASSIGN:
3351         if (o && o->op_type == OP_RV2GV)
3352             return FALSE;
3353         /* FALLTHROUGH */
3354     case OP_PREINC:
3355     case OP_PREDEC:
3356     case OP_POSTINC:
3357     case OP_POSTDEC:
3358     case OP_I_PREINC:
3359     case OP_I_PREDEC:
3360     case OP_I_POSTINC:
3361     case OP_I_POSTDEC:
3362     case OP_POW:
3363     case OP_MULTIPLY:
3364     case OP_DIVIDE:
3365     case OP_MODULO:
3366     case OP_REPEAT:
3367     case OP_ADD:
3368     case OP_SUBTRACT:
3369     case OP_I_MULTIPLY:
3370     case OP_I_DIVIDE:
3371     case OP_I_MODULO:
3372     case OP_I_ADD:
3373     case OP_I_SUBTRACT:
3374     case OP_LEFT_SHIFT:
3375     case OP_RIGHT_SHIFT:
3376     case OP_BIT_AND:
3377     case OP_BIT_XOR:
3378     case OP_BIT_OR:
3379     case OP_NBIT_AND:
3380     case OP_NBIT_XOR:
3381     case OP_NBIT_OR:
3382     case OP_SBIT_AND:
3383     case OP_SBIT_XOR:
3384     case OP_SBIT_OR:
3385     case OP_CONCAT:
3386     case OP_SUBST:
3387     case OP_TRANS:
3388     case OP_TRANSR:
3389     case OP_READ:
3390     case OP_SYSREAD:
3391     case OP_RECV:
3392     case OP_ANDASSIGN:
3393     case OP_ORASSIGN:
3394     case OP_DORASSIGN:
3395     case OP_VEC:
3396     case OP_SUBSTR:
3397         return TRUE;
3398     default:
3399         return FALSE;
3400     }
3401 }
3402
3403 STATIC bool
3404 S_is_handle_constructor(const OP *o, I32 numargs)
3405 {
3406     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3407
3408     switch (o->op_type) {
3409     case OP_PIPE_OP:
3410     case OP_SOCKPAIR:
3411         if (numargs == 2)
3412             return TRUE;
3413         /* FALLTHROUGH */
3414     case OP_SYSOPEN:
3415     case OP_OPEN:
3416     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3417     case OP_SOCKET:
3418     case OP_OPEN_DIR:
3419     case OP_ACCEPT:
3420         if (numargs == 1)
3421             return TRUE;
3422         /* FALLTHROUGH */
3423     default:
3424         return FALSE;
3425     }
3426 }
3427
3428 static OP *
3429 S_refkids(pTHX_ OP *o, I32 type)
3430 {
3431     if (o && o->op_flags & OPf_KIDS) {
3432         OP *kid;
3433         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3434             ref(kid, type);
3435     }
3436     return o;
3437 }
3438
3439 OP *
3440 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3441 {
3442     dVAR;
3443     OP *kid;
3444
3445     PERL_ARGS_ASSERT_DOREF;
3446
3447     if (PL_parser && PL_parser->error_count)
3448         return o;
3449
3450     switch (o->op_type) {
3451     case OP_ENTERSUB:
3452         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3453             !(o->op_flags & OPf_STACKED)) {
3454             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3455             assert(cUNOPo->op_first->op_type == OP_NULL);
3456             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3457             o->op_flags |= OPf_SPECIAL;
3458         }
3459         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3460             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3461                               : type == OP_RV2HV ? OPpDEREF_HV
3462                               : OPpDEREF_SV);
3463             o->op_flags |= OPf_MOD;
3464         }
3465
3466         break;
3467
3468     case OP_COND_EXPR:
3469         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3470             doref(kid, type, set_op_ref);
3471         break;
3472     case OP_RV2SV:
3473         if (type == OP_DEFINED)
3474             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3475         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3476         /* FALLTHROUGH */
3477     case OP_PADSV:
3478         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3479             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3480                               : type == OP_RV2HV ? OPpDEREF_HV
3481                               : OPpDEREF_SV);
3482             o->op_flags |= OPf_MOD;
3483         }
3484         break;
3485
3486     case OP_RV2AV:
3487     case OP_RV2HV:
3488         if (set_op_ref)
3489             o->op_flags |= OPf_REF;
3490         /* FALLTHROUGH */
3491     case OP_RV2GV:
3492         if (type == OP_DEFINED)
3493             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3494         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3495         break;
3496
3497     case OP_PADAV:
3498     case OP_PADHV:
3499         if (set_op_ref)
3500             o->op_flags |= OPf_REF;
3501         break;
3502
3503     case OP_SCALAR:
3504     case OP_NULL:
3505         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3506             break;
3507         doref(cBINOPo->op_first, type, set_op_ref);
3508         break;
3509     case OP_AELEM:
3510     case OP_HELEM:
3511         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3512         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3513             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3514                               : type == OP_RV2HV ? OPpDEREF_HV
3515                               : OPpDEREF_SV);
3516             o->op_flags |= OPf_MOD;
3517         }
3518         break;
3519
3520     case OP_SCOPE:
3521     case OP_LEAVE:
3522         set_op_ref = FALSE;
3523         /* FALLTHROUGH */
3524     case OP_ENTER:
3525     case OP_LIST:
3526         if (!(o->op_flags & OPf_KIDS))
3527             break;
3528         doref(cLISTOPo->op_last, type, set_op_ref);
3529         break;
3530     default:
3531         break;
3532     }
3533     return scalar(o);
3534
3535 }
3536
3537 STATIC OP *
3538 S_dup_attrlist(pTHX_ OP *o)
3539 {
3540     OP *rop;
3541
3542     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3543
3544     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3545      * where the first kid is OP_PUSHMARK and the remaining ones
3546      * are OP_CONST.  We need to push the OP_CONST values.
3547      */
3548     if (o->op_type == OP_CONST)
3549         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3550     else {
3551         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3552         rop = NULL;
3553         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3554             if (o->op_type == OP_CONST)
3555                 rop = op_append_elem(OP_LIST, rop,
3556                                   newSVOP(OP_CONST, o->op_flags,
3557                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3558         }
3559     }
3560     return rop;
3561 }
3562
3563 STATIC void
3564 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3565 {
3566     PERL_ARGS_ASSERT_APPLY_ATTRS;
3567     {
3568         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3569
3570         /* fake up C<use attributes $pkg,$rv,@attrs> */
3571
3572 #define ATTRSMODULE "attributes"
3573 #define ATTRSMODULE_PM "attributes.pm"
3574
3575         Perl_load_module(
3576           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3577           newSVpvs(ATTRSMODULE),
3578           NULL,
3579           op_prepend_elem(OP_LIST,
3580                           newSVOP(OP_CONST, 0, stashsv),
3581                           op_prepend_elem(OP_LIST,
3582                                           newSVOP(OP_CONST, 0,
3583                                                   newRV(target)),
3584                                           dup_attrlist(attrs))));
3585     }
3586 }
3587
3588 STATIC void
3589 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3590 {
3591     OP *pack, *imop, *arg;
3592     SV *meth, *stashsv, **svp;
3593
3594     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3595
3596     if (!attrs)
3597         return;
3598
3599     assert(target->op_type == OP_PADSV ||
3600            target->op_type == OP_PADHV ||
3601            target->op_type == OP_PADAV);
3602
3603     /* Ensure that attributes.pm is loaded. */
3604     /* Don't force the C<use> if we don't need it. */
3605     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3606     if (svp && *svp != &PL_sv_undef)
3607         NOOP;   /* already in %INC */
3608     else
3609         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3610                                newSVpvs(ATTRSMODULE), NULL);
3611
3612     /* Need package name for method call. */
3613     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3614
3615     /* Build up the real arg-list. */
3616     stashsv = newSVhek(HvNAME_HEK(stash));
3617
3618     arg = newOP(OP_PADSV, 0);
3619     arg->op_targ = target->op_targ;
3620     arg = op_prepend_elem(OP_LIST,
3621                        newSVOP(OP_CONST, 0, stashsv),
3622                        op_prepend_elem(OP_LIST,
3623                                     newUNOP(OP_REFGEN, 0,
3624                                             arg),
3625                                     dup_attrlist(attrs)));
3626
3627     /* Fake up a method call to import */
3628     meth = newSVpvs_share("import");
3629     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3630                    op_append_elem(OP_LIST,
3631                                op_prepend_elem(OP_LIST, pack, arg),
3632                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3633
3634     /* Combine the ops. */
3635     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3636 }
3637
3638 /*
3639 =notfor apidoc apply_attrs_string
3640
3641 Attempts to apply a list of attributes specified by the C<attrstr> and
3642 C<len> arguments to the subroutine identified by the C<cv> argument which
3643 is expected to be associated with the package identified by the C<stashpv>
3644 argument (see L<attributes>).  It gets this wrong, though, in that it
3645 does not correctly identify the boundaries of the individual attribute
3646 specifications within C<attrstr>.  This is not really intended for the
3647 public API, but has to be listed here for systems such as AIX which
3648 need an explicit export list for symbols.  (It's called from XS code
3649 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3650 to respect attribute syntax properly would be welcome.
3651
3652 =cut
3653 */
3654
3655 void
3656 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3657                         const char *attrstr, STRLEN len)
3658 {
3659     OP *attrs = NULL;
3660
3661     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3662
3663     if (!len) {
3664         len = strlen(attrstr);
3665     }
3666
3667     while (len) {
3668         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3669         if (len) {
3670             const char * const sstr = attrstr;
3671             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3672             attrs = op_append_elem(OP_LIST, attrs,
3673                                 newSVOP(OP_CONST, 0,
3674                                         newSVpvn(sstr, attrstr-sstr)));
3675         }
3676     }
3677
3678     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3679                      newSVpvs(ATTRSMODULE),
3680                      NULL, op_prepend_elem(OP_LIST,
3681                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3682                                   op_prepend_elem(OP_LIST,
3683                                                newSVOP(OP_CONST, 0,
3684                                                        newRV(MUTABLE_SV(cv))),
3685                                                attrs)));
3686 }
3687
3688 STATIC void
3689 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3690 {
3691     OP *new_proto = NULL;
3692     STRLEN pvlen;
3693     char *pv;
3694     OP *o;
3695
3696     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3697
3698     if (!*attrs)
3699         return;
3700
3701     o = *attrs;
3702     if (o->op_type == OP_CONST) {
3703         pv = SvPV(cSVOPo_sv, pvlen);
3704         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3705             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3706             SV ** const tmpo = cSVOPx_svp(o);
3707             SvREFCNT_dec(cSVOPo_sv);
3708             *tmpo = tmpsv;
3709             new_proto = o;
3710             *attrs = NULL;
3711         }
3712     } else if (o->op_type == OP_LIST) {
3713         OP * lasto;
3714         assert(o->op_flags & OPf_KIDS);
3715         lasto = cLISTOPo->op_first;
3716         assert(lasto->op_type == OP_PUSHMARK);
3717         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3718             if (o->op_type == OP_CONST) {
3719                 pv = SvPV(cSVOPo_sv, pvlen);
3720                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3721                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3722                     SV ** const tmpo = cSVOPx_svp(o);
3723                     SvREFCNT_dec(cSVOPo_sv);
3724                     *tmpo = tmpsv;
3725                     if (new_proto && ckWARN(WARN_MISC)) {
3726                         STRLEN new_len;
3727                         const char * newp = SvPV(cSVOPo_sv, new_len);
3728                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3729                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3730                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3731                         op_free(new_proto);
3732                     }
3733                     else if (new_proto)
3734                         op_free(new_proto);
3735                     new_proto = o;
3736                     /* excise new_proto from the list */
3737                     op_sibling_splice(*attrs, lasto, 1, NULL);
3738                     o = lasto;
3739                     continue;
3740                 }
3741             }
3742             lasto = o;
3743         }
3744         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3745            would get pulled in with no real need */
3746         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3747             op_free(*attrs);
3748             *attrs = NULL;
3749         }
3750     }
3751
3752     if (new_proto) {
3753         SV *svname;
3754         if (isGV(name)) {
3755             svname = sv_newmortal();
3756             gv_efullname3(svname, name, NULL);
3757         }
3758         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3759             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3760         else
3761             svname = (SV *)name;
3762         if (ckWARN(WARN_ILLEGALPROTO))
3763             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3764         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3765             STRLEN old_len, new_len;
3766             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3767             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3768
3769             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3770                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3771                 " in %" SVf,
3772                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3773                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3774                 SVfARG(svname));
3775         }
3776         if (*proto)
3777             op_free(*proto);
3778         *proto = new_proto;
3779     }
3780 }
3781
3782 static void
3783 S_cant_declare(pTHX_ OP *o)
3784 {
3785     if (o->op_type == OP_NULL
3786      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3787         o = cUNOPo->op_first;
3788     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3789                              o->op_type == OP_NULL
3790                                && o->op_flags & OPf_SPECIAL
3791                                  ? "do block"
3792                                  : OP_DESC(o),
3793                              PL_parser->in_my == KEY_our   ? "our"   :
3794                              PL_parser->in_my == KEY_state ? "state" :
3795                                                              "my"));
3796 }
3797
3798 STATIC OP *
3799 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3800 {
3801     I32 type;
3802     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3803
3804     PERL_ARGS_ASSERT_MY_KID;
3805
3806     if (!o || (PL_parser && PL_parser->error_count))
3807         return o;
3808
3809     type = o->op_type;
3810
3811     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3812         OP *kid;
3813         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3814             my_kid(kid, attrs, imopsp);
3815         return o;
3816     } else if (type == OP_UNDEF || type == OP_STUB) {
3817         return o;
3818     } else if (type == OP_RV2SV ||      /* "our" declaration */
3819                type == OP_RV2AV ||
3820                type == OP_RV2HV) {
3821         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3822             S_cant_declare(aTHX_ o);
3823         } else if (attrs) {
3824             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3825             assert(PL_parser);
3826             PL_parser->in_my = FALSE;
3827             PL_parser->in_my_stash = NULL;
3828             apply_attrs(GvSTASH(gv),
3829                         (type == OP_RV2SV ? GvSV(gv) :
3830                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3831                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3832                         attrs);
3833         }
3834         o->op_private |= OPpOUR_INTRO;
3835         return o;
3836     }
3837     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3838         if (!FEATURE_MYREF_IS_ENABLED)
3839             Perl_croak(aTHX_ "The experimental declared_refs "
3840                              "feature is not enabled");
3841         Perl_ck_warner_d(aTHX_
3842              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3843             "Declaring references is experimental");
3844         /* Kid is a nulled OP_LIST, handled above.  */
3845         my_kid(cUNOPo->op_first, attrs, imopsp);
3846         return o;
3847     }
3848     else if (type != OP_PADSV &&
3849              type != OP_PADAV &&
3850              type != OP_PADHV &&
3851              type != OP_PUSHMARK)
3852     {
3853         S_cant_declare(aTHX_ o);
3854         return o;
3855     }
3856     else if (attrs && type != OP_PUSHMARK) {
3857         HV *stash;
3858
3859         assert(PL_parser);
3860         PL_parser->in_my = FALSE;
3861         PL_parser->in_my_stash = NULL;
3862
3863         /* check for C<my Dog $spot> when deciding package */
3864         stash = PAD_COMPNAME_TYPE(o->op_targ);
3865         if (!stash)
3866             stash = PL_curstash;
3867         apply_attrs_my(stash, o, attrs, imopsp);
3868     }
3869     o->op_flags |= OPf_MOD;
3870     o->op_private |= OPpLVAL_INTRO;
3871     if (stately)
3872         o->op_private |= OPpPAD_STATE;
3873     return o;
3874 }
3875
3876 OP *
3877 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3878 {
3879     OP *rops;
3880     int maybe_scalar = 0;
3881
3882     PERL_ARGS_ASSERT_MY_ATTRS;
3883
3884 /* [perl #17376]: this appears to be premature, and results in code such as
3885    C< our(%x); > executing in list mode rather than void mode */
3886 #if 0
3887     if (o->op_flags & OPf_PARENS)
3888         list(o);
3889     else
3890         maybe_scalar = 1;
3891 #else
3892     maybe_scalar = 1;
3893 #endif
3894     if (attrs)
3895         SAVEFREEOP(attrs);
3896     rops = NULL;
3897     o = my_kid(o, attrs, &rops);
3898     if (rops) {
3899         if (maybe_scalar && o->op_type == OP_PADSV) {
3900             o = scalar(op_append_list(OP_LIST, rops, o));
3901             o->op_private |= OPpLVAL_INTRO;
3902         }
3903         else {
3904             /* The listop in rops might have a pushmark at the beginning,
3905                which will mess up list assignment. */
3906             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3907             if (rops->op_type == OP_LIST && 
3908                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3909             {
3910                 OP * const pushmark = lrops->op_first;
3911                 /* excise pushmark */
3912                 op_sibling_splice(rops, NULL, 1, NULL);
3913                 op_free(pushmark);
3914             }
3915             o = op_append_list(OP_LIST, o, rops);
3916         }
3917     }
3918     PL_parser->in_my = FALSE;
3919     PL_parser->in_my_stash = NULL;
3920     return o;
3921 }
3922
3923 OP *
3924 Perl_sawparens(pTHX_ OP *o)
3925 {
3926     PERL_UNUSED_CONTEXT;
3927     if (o)
3928         o->op_flags |= OPf_PARENS;
3929     return o;
3930 }
3931
3932 OP *
3933 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3934 {
3935     OP *o;
3936     bool ismatchop = 0;
3937     const OPCODE ltype = left->op_type;
3938     const OPCODE rtype = right->op_type;
3939
3940     PERL_ARGS_ASSERT_BIND_MATCH;
3941
3942     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3943           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3944     {
3945       const char * const desc
3946           = PL_op_desc[(
3947                           rtype == OP_SUBST || rtype == OP_TRANS
3948                        || rtype == OP_TRANSR
3949                        )
3950                        ? (int)rtype : OP_MATCH];
3951       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3952       SV * const name =
3953         S_op_varname(aTHX_ left);
3954       if (name)
3955         Perl_warner(aTHX_ packWARN(WARN_MISC),
3956              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3957              desc, SVfARG(name), SVfARG(name));
3958       else {
3959         const char * const sample = (isary
3960              ? "@array" : "%hash");
3961         Perl_warner(aTHX_ packWARN(WARN_MISC),
3962              "Applying %s to %s will act on scalar(%s)",
3963              desc, sample, sample);
3964       }
3965     }
3966
3967     if (rtype == OP_CONST &&
3968         cSVOPx(right)->op_private & OPpCONST_BARE &&
3969         cSVOPx(right)->op_private & OPpCONST_STRICT)
3970     {
3971         no_bareword_allowed(right);
3972     }
3973
3974     /* !~ doesn't make sense with /r, so error on it for now */
3975     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3976         type == OP_NOT)
3977         /* diag_listed_as: Using !~ with %s doesn't make sense */
3978         yyerror("Using !~ with s///r doesn't make sense");
3979     if (rtype == OP_TRANSR && type == OP_NOT)
3980         /* diag_listed_as: Using !~ with %s doesn't make sense */
3981         yyerror("Using !~ with tr///r doesn't make sense");
3982
3983     ismatchop = (rtype == OP_MATCH ||
3984                  rtype == OP_SUBST ||
3985                  rtype == OP_TRANS || rtype == OP_TRANSR)
3986              && !(right->op_flags & OPf_SPECIAL);
3987     if (ismatchop && right->op_private & OPpTARGET_MY) {
3988         right->op_targ = 0;
3989         right->op_private &= ~OPpTARGET_MY;
3990     }
3991     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3992         if (left->op_type == OP_PADSV
3993          && !(left->op_private & OPpLVAL_INTRO))
3994         {
3995             right->op_targ = left->op_targ;
3996             op_free(left);
3997             o = right;
3998         }
3999         else {
4000             right->op_flags |= OPf_STACKED;
4001             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4002             ! (rtype == OP_TRANS &&
4003                right->op_private & OPpTRANS_IDENTICAL) &&
4004             ! (rtype == OP_SUBST &&
4005                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4006                 left = op_lvalue(left, rtype);
4007             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4008                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4009             else
4010                 o = op_prepend_elem(rtype, scalar(left), right);
4011         }
4012         if (type == OP_NOT)
4013             return newUNOP(OP_NOT, 0, scalar(o));
4014         return o;
4015     }
4016     else
4017         return bind_match(type, left,
4018                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4019 }
4020
4021 OP *
4022 Perl_invert(pTHX_ OP *o)
4023 {
4024     if (!o)
4025         return NULL;
4026     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4027 }
4028
4029 /*
4030 =for apidoc Amx|OP *|op_scope|OP *o
4031
4032 Wraps up an op tree with some additional ops so that at runtime a dynamic
4033 scope will be created.  The original ops run in the new dynamic scope,
4034 and then, provided that they exit normally, the scope will be unwound.
4035 The additional ops used to create and unwind the dynamic scope will
4036 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4037 instead if the ops are simple enough to not need the full dynamic scope
4038 structure.
4039
4040 =cut
4041 */
4042
4043 OP *
4044 Perl_op_scope(pTHX_ OP *o)
4045 {
4046     dVAR;
4047     if (o) {
4048         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4049             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4050             OpTYPE_set(o, OP_LEAVE);
4051         }
4052         else if (o->op_type == OP_LINESEQ) {
4053             OP *kid;
4054             OpTYPE_set(o, OP_SCOPE);
4055             kid = ((LISTOP*)o)->op_first;
4056             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4057                 op_null(kid);
4058
4059                 /* The following deals with things like 'do {1 for 1}' */
4060                 kid = OpSIBLING(kid);
4061                 if (kid &&
4062                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4063                     op_null(kid);
4064             }
4065         }
4066         else
4067             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4068     }
4069     return o;
4070 }
4071
4072 OP *
4073 Perl_op_unscope(pTHX_ OP *o)
4074 {
4075     if (o && o->op_type == OP_LINESEQ) {
4076         OP *kid = cLISTOPo->op_first;
4077         for(; kid; kid = OpSIBLING(kid))
4078             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4079                 op_null(kid);
4080     }
4081     return o;
4082 }
4083
4084 /*
4085 =for apidoc Am|int|block_start|int full
4086
4087 Handles compile-time scope entry.
4088 Arranges for hints to be restored on block
4089 exit and also handles pad sequence numbers to make lexical variables scope
4090 right.  Returns a savestack index for use with C<block_end>.
4091
4092 =cut
4093 */
4094
4095 int
4096 Perl_block_start(pTHX_ int full)
4097 {
4098     const int retval = PL_savestack_ix;
4099
4100     PL_compiling.cop_seq = PL_cop_seqmax;
4101     COP_SEQMAX_INC;
4102     pad_block_start(full);
4103     SAVEHINTS();
4104     PL_hints &= ~HINT_BLOCK_SCOPE;
4105     SAVECOMPILEWARNINGS();
4106     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4107     SAVEI32(PL_compiling.cop_seq);
4108     PL_compiling.cop_seq = 0;
4109
4110     CALL_BLOCK_HOOKS(bhk_start, full);
4111
4112     return retval;
4113 }
4114
4115 /*
4116 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4117
4118 Handles compile-time scope exit.  C<floor>
4119 is the savestack index returned by
4120 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4121 possibly modified.
4122
4123 =cut
4124 */
4125
4126 OP*
4127 Perl_block_end(pTHX_ I32 floor, OP *seq)
4128 {
4129     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4130     OP* retval = scalarseq(seq);
4131     OP *o;
4132
4133     /* XXX Is the null PL_parser check necessary here? */
4134     assert(PL_parser); /* Let’s find out under debugging builds.  */
4135     if (PL_parser && PL_parser->parsed_sub) {
4136         o = newSTATEOP(0, NULL, NULL);
4137         op_null(o);
4138         retval = op_append_elem(OP_LINESEQ, retval, o);
4139     }
4140
4141     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4142
4143     LEAVE_SCOPE(floor);
4144     if (needblockscope)
4145         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4146     o = pad_leavemy();
4147
4148     if (o) {
4149         /* pad_leavemy has created a sequence of introcv ops for all my
4150            subs declared in the block.  We have to replicate that list with
4151            clonecv ops, to deal with this situation:
4152
4153                sub {
4154                    my sub s1;
4155                    my sub s2;
4156                    sub s1 { state sub foo { \&s2 } }
4157                }->()
4158
4159            Originally, I was going to have introcv clone the CV and turn
4160            off the stale flag.  Since &s1 is declared before &s2, the
4161            introcv op for &s1 is executed (on sub entry) before the one for
4162            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4163            cloned, since it is a state sub) closes over &s2 and expects
4164            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4165            then &s2 is still marked stale.  Since &s1 is not active, and
4166            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4167            ble will not stay shared’ warning.  Because it is the same stub
4168            that will be used when the introcv op for &s2 is executed, clos-
4169            ing over it is safe.  Hence, we have to turn off the stale flag
4170            on all lexical subs in the block before we clone any of them.
4171            Hence, having introcv clone the sub cannot work.  So we create a
4172            list of ops like this:
4173
4174                lineseq
4175                   |
4176                   +-- introcv
4177                   |
4178                   +-- introcv
4179                   |
4180                   +-- introcv
4181                   |
4182                   .
4183                   .
4184                   .
4185                   |
4186                   +-- clonecv
4187                   |
4188                   +-- clonecv
4189                   |
4190                   +-- clonecv
4191                   |
4192                   .
4193                   .
4194                   .
4195          */
4196         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4197         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4198         for (;; kid = OpSIBLING(kid)) {
4199             OP *newkid = newOP(OP_CLONECV, 0);
4200             newkid->op_targ = kid->op_targ;
4201             o = op_append_elem(OP_LINESEQ, o, newkid);
4202             if (kid == last) break;
4203         }
4204         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4205     }
4206
4207     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4208
4209     return retval;
4210 }
4211
4212 /*
4213 =head1 Compile-time scope hooks
4214
4215 =for apidoc Aox||blockhook_register
4216
4217 Register a set of hooks to be called when the Perl lexical scope changes
4218 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4219
4220 =cut
4221 */
4222
4223 void
4224 Perl_blockhook_register(pTHX_ BHK *hk)
4225 {
4226     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4227
4228     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4229 }
4230
4231 void
4232 Perl_newPROG(pTHX_ OP *o)
4233 {
4234     OP *start;
4235
4236     PERL_ARGS_ASSERT_NEWPROG;
4237
4238     if (PL_in_eval) {
4239         PERL_CONTEXT *cx;
4240         I32 i;
4241         if (PL_eval_root)
4242                 return;
4243         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4244                                ((PL_in_eval & EVAL_KEEPERR)
4245                                 ? OPf_SPECIAL : 0), o);
4246
4247         cx = CX_CUR();
4248         assert(CxTYPE(cx) == CXt_EVAL);
4249
4250         if ((cx->blk_gimme & G_WANT) == G_VOID)
4251             scalarvoid(PL_eval_root);
4252         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4253             list(PL_eval_root);
4254         else
4255             scalar(PL_eval_root);
4256
4257         start = op_linklist(PL_eval_root);
4258         PL_eval_root->op_next = 0;
4259         i = PL_savestack_ix;
4260         SAVEFREEOP(o);
4261         ENTER;
4262         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4263         LEAVE;
4264         PL_savestack_ix = i;
4265     }
4266     else {
4267         if (o->op_type == OP_STUB) {
4268             /* This block is entered if nothing is compiled for the main
4269                program. This will be the case for an genuinely empty main
4270                program, or one which only has BEGIN blocks etc, so already
4271                run and freed.
4272
4273                Historically (5.000) the guard above was !o. However, commit
4274                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4275                c71fccf11fde0068, changed perly.y so that newPROG() is now
4276                called with the output of block_end(), which returns a new
4277                OP_STUB for the case of an empty optree. ByteLoader (and
4278                maybe other things) also take this path, because they set up
4279                PL_main_start and PL_main_root directly, without generating an
4280                optree.
4281
4282                If the parsing the main program aborts (due to parse errors,
4283                or due to BEGIN or similar calling exit), then newPROG()
4284                isn't even called, and hence this code path and its cleanups
4285                are skipped. This shouldn't make a make a difference:
4286                * a non-zero return from perl_parse is a failure, and
4287                  perl_destruct() should be called immediately.
4288                * however, if exit(0) is called during the parse, then
4289                  perl_parse() returns 0, and perl_run() is called. As
4290                  PL_main_start will be NULL, perl_run() will return
4291                  promptly, and the exit code will remain 0.
4292             */
4293
4294             PL_comppad_name = 0;
4295             PL_compcv = 0;
4296             S_op_destroy(aTHX_ o);
4297             return;
4298         }
4299         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4300         PL_curcop = &PL_compiling;
4301         start = LINKLIST(PL_main_root);
4302         PL_main_root->op_next = 0;
4303         S_process_optree(aTHX_ NULL, PL_main_root, start);
4304         cv_forget_slab(PL_compcv);
4305         PL_compcv = 0;
4306
4307         /* Register with debugger */
4308         if (PERLDB_INTER) {
4309             CV * const cv = get_cvs("DB::postponed", 0);
4310             if (cv) {
4311                 dSP;
4312                 PUSHMARK(SP);
4313                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4314                 PUTBACK;
4315                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4316             }
4317         }
4318     }
4319 }
4320
4321 OP *
4322 Perl_localize(pTHX_ OP *o, I32 lex)
4323 {
4324     PERL_ARGS_ASSERT_LOCALIZE;
4325
4326     if (o->op_flags & OPf_PARENS)
4327 /* [perl #17376]: this appears to be premature, and results in code such as
4328    C< our(%x); > executing in list mode rather than void mode */
4329 #if 0
4330         list(o);
4331 #else
4332         NOOP;
4333 #endif
4334     else {
4335         if ( PL_parser->bufptr > PL_parser->oldbufptr
4336             && PL_parser->bufptr[-1] == ','
4337             && ckWARN(WARN_PARENTHESIS))
4338         {
4339             char *s = PL_parser->bufptr;
4340             bool sigil = FALSE;
4341
4342             /* some heuristics to detect a potential error */
4343             while (*s && (strchr(", \t\n", *s)))
4344                 s++;
4345
4346             while (1) {
4347                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4348                        && *++s
4349                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4350                     s++;
4351                     sigil = TRUE;
4352                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4353                         s++;
4354                     while (*s && (strchr(", \t\n", *s)))
4355                         s++;
4356                 }
4357                 else
4358                     break;
4359             }
4360             if (sigil && (*s == ';' || *s == '=')) {
4361                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4362                                 "Parentheses missing around \"%s\" list",
4363                                 lex
4364                                     ? (PL_parser->in_my == KEY_our
4365                                         ? "our"
4366                                         : PL_parser->in_my == KEY_state
4367                                             ? "state"
4368                                             : "my")
4369                                     : "local");
4370             }
4371         }
4372     }
4373     if (lex)
4374         o = my(o);
4375     else
4376         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4377     PL_parser->in_my = FALSE;
4378     PL_parser->in_my_stash = NULL;
4379     return o;
4380 }
4381
4382 OP *
4383 Perl_jmaybe(pTHX_ OP *o)
4384 {
4385     PERL_ARGS_ASSERT_JMAYBE;
4386
4387     if (o->op_type == OP_LIST) {
4388         OP * const o2
4389             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4390         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4391     }
4392     return o;
4393 }
4394
4395 PERL_STATIC_INLINE OP *
4396 S_op_std_init(pTHX_ OP *o)
4397 {
4398     I32 type = o->op_type;
4399
4400     PERL_ARGS_ASSERT_OP_STD_INIT;
4401
4402     if (PL_opargs[type] & OA_RETSCALAR)
4403         scalar(o);
4404     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4405         o->op_targ = pad_alloc(type, SVs_PADTMP);
4406
4407     return o;
4408 }
4409
4410 PERL_STATIC_INLINE OP *
4411 S_op_integerize(pTHX_ OP *o)
4412 {
4413     I32 type = o->op_type;
4414
4415     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4416
4417     /* integerize op. */
4418     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4419     {
4420         dVAR;
4421         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4422     }
4423
4424     if (type == OP_NEGATE)
4425         /* XXX might want a ck_negate() for this */
4426         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4427
4428     return o;
4429 }
4430
4431 static OP *
4432 S_fold_constants(pTHX_ OP *const o)
4433 {
4434     dVAR;
4435     OP * VOL curop;
4436     OP *newop;
4437     VOL I32 type = o->op_type;
4438     bool is_stringify;
4439     SV * VOL sv = NULL;
4440     int ret = 0;
4441     OP *old_next;
4442     SV * const oldwarnhook = PL_warnhook;
4443     SV * const olddiehook  = PL_diehook;
4444     COP not_compiling;
4445     U8 oldwarn = PL_dowarn;
4446     I32 old_cxix;
4447     dJMPENV;
4448
4449     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4450
4451     if (!(PL_opargs[type] & OA_FOLDCONST))
4452         goto nope;
4453
4454     switch (type) {
4455     case OP_UCFIRST:
4456     case OP_LCFIRST:
4457     case OP_UC:
4458     case OP_LC:
4459     case OP_FC:
4460 #ifdef USE_LOCALE_CTYPE
4461         if (IN_LC_COMPILETIME(LC_CTYPE))
4462             goto nope;
4463 #endif
4464         break;
4465     case OP_SLT:
4466     case OP_SGT:
4467     case OP_SLE:
4468     case OP_SGE:
4469     case OP_SCMP:
4470 #ifdef USE_LOCALE_COLLATE
4471         if (IN_LC_COMPILETIME(LC_COLLATE))
4472             goto nope;
4473 #endif
4474         break;
4475     case OP_SPRINTF:
4476         /* XXX what about the numeric ops? */
4477 #ifdef USE_LOCALE_NUMERIC
4478         if (IN_LC_COMPILETIME(LC_NUMERIC))
4479             goto nope;
4480 #endif
4481         break;
4482     case OP_PACK:
4483         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4484           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4485             goto nope;
4486         {
4487             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4488             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4489             {
4490                 const char *s = SvPVX_const(sv);
4491                 while (s < SvEND(sv)) {
4492                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4493                     s++;
4494                 }
4495             }
4496         }
4497         break;
4498     case OP_REPEAT:
4499         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4500         break;
4501     case OP_SREFGEN:
4502         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4503          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4504             goto nope;
4505     }
4506
4507     if (PL_parser && PL_parser->error_count)
4508         goto nope;              /* Don't try to run w/ errors */
4509
4510     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4511         switch (curop->op_type) {
4512         case OP_CONST:
4513             if (   (curop->op_private & OPpCONST_BARE)
4514                 && (curop->op_private & OPpCONST_STRICT)) {
4515                 no_bareword_allowed(curop);
4516                 goto nope;
4517             }
4518             /* FALLTHROUGH */
4519         case OP_LIST:
4520         case OP_SCALAR:
4521         case OP_NULL:
4522         case OP_PUSHMARK:
4523             /* Foldable; move to next op in list */
4524             break;
4525
4526         default:
4527             /* No other op types are considered foldable */
4528             goto nope;
4529         }
4530     }
4531
4532     curop = LINKLIST(o);
4533     old_next = o->op_next;
4534     o->op_next = 0;
4535     PL_op = curop;
4536
4537     old_cxix = cxstack_ix;
4538     create_eval_scope(NULL, G_FAKINGEVAL);
4539
4540     /* Verify that we don't need to save it:  */
4541     assert(PL_curcop == &PL_compiling);
4542     StructCopy(&PL_compiling, &not_compiling, COP);
4543     PL_curcop = &not_compiling;
4544     /* The above ensures that we run with all the correct hints of the
4545        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4546     assert(IN_PERL_RUNTIME);
4547     PL_warnhook = PERL_WARNHOOK_FATAL;
4548     PL_diehook  = NULL;
4549     JMPENV_PUSH(ret);
4550
4551     /* Effective $^W=1.  */
4552     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4553         PL_dowarn |= G_WARN_ON;
4554
4555     switch (ret) {
4556     case 0:
4557         CALLRUNOPS(aTHX);
4558         sv = *(PL_stack_sp--);
4559         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4560             pad_swipe(o->op_targ,  FALSE);
4561         }
4562         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4563             SvREFCNT_inc_simple_void(sv);
4564             SvTEMP_off(sv);
4565         }
4566         else { assert(SvIMMORTAL(sv)); }
4567         break;
4568     case 3:
4569         /* Something tried to die.  Abandon constant folding.  */
4570         /* Pretend the error never happened.  */
4571         CLEAR_ERRSV();
4572         o->op_next = old_next;
4573         break;
4574     default:
4575         JMPENV_POP;
4576         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4577         PL_warnhook = oldwarnhook;
4578         PL_diehook  = olddiehook;
4579         /* XXX note that this croak may fail as we've already blown away
4580          * the stack - eg any nested evals */
4581         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4582     }
4583     JMPENV_POP;
4584     PL_dowarn   = oldwarn;
4585     PL_warnhook = oldwarnhook;
4586     PL_diehook  = olddiehook;
4587     PL_curcop = &PL_compiling;
4588
4589     /* if we croaked, depending on how we croaked the eval scope
4590      * may or may not have already been popped */
4591     if (cxstack_ix > old_cxix) {
4592         assert(cxstack_ix == old_cxix + 1);
4593         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4594         delete_eval_scope();
4595     }
4596     if (ret)
4597         goto nope;
4598
4599     /* OP_STRINGIFY and constant folding are used to implement qq.
4600        Here the constant folding is an implementation detail that we
4601        want to hide.  If the stringify op is itself already marked
4602        folded, however, then it is actually a folded join.  */
4603     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4604     op_free(o);
4605     assert(sv);
4606     if (is_stringify)
4607         SvPADTMP_off(sv);
4608     else if (!SvIMMORTAL(sv)) {
4609         SvPADTMP_on(sv);
4610         SvREADONLY_on(sv);
4611     }
4612     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4613     if (!is_stringify) newop->op_folded = 1;
4614     return newop;
4615
4616  nope:
4617     return o;
4618 }
4619
4620 static OP *
4621 S_gen_constant_list(pTHX_ OP *o)
4622 {
4623     dVAR;
4624     OP *curop, *old_next;
4625     SV * const oldwarnhook = PL_warnhook;
4626     SV * const olddiehook  = PL_diehook;
4627     COP *old_curcop;
4628     U8 oldwarn = PL_dowarn;
4629     SV **svp;
4630     AV *av;
4631     I32 old_cxix;
4632     COP not_compiling;
4633     int ret = 0;
4634     dJMPENV;
4635     bool op_was_null;
4636
4637     list(o);
4638     if (PL_parser && PL_parser->error_count)
4639         return o;               /* Don't attempt to run with errors */
4640
4641     curop = LINKLIST(o);
4642     old_next = o->op_next;
4643     o->op_next = 0;
4644     op_was_null = o->op_type == OP_NULL;
4645     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
4646         o->op_type = OP_CUSTOM;
4647     CALL_PEEP(curop);
4648     if (op_was_null)
4649         o->op_type = OP_NULL;
4650     S_prune_chain_head(&curop);
4651     PL_op = curop;
4652
4653     old_cxix = cxstack_ix;
4654     create_eval_scope(NULL, G_FAKINGEVAL);
4655
4656     old_curcop = PL_curcop;
4657     StructCopy(old_curcop, &not_compiling, COP);
4658     PL_curcop = &not_compiling;
4659     /* The above ensures that we run with all the correct hints of the
4660        current COP, but that IN_PERL_RUNTIME is true. */
4661     assert(IN_PERL_RUNTIME);
4662     PL_warnhook = PERL_WARNHOOK_FATAL;
4663     PL_diehook  = NULL;
4664     JMPENV_PUSH(ret);
4665
4666     /* Effective $^W=1.  */
4667     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4668         PL_dowarn |= G_WARN_ON;
4669
4670     switch (ret) {
4671     case 0:
4672         Perl_pp_pushmark(aTHX);
4673         CALLRUNOPS(aTHX);
4674         PL_op = curop;
4675         assert (!(curop->op_flags & OPf_SPECIAL));
4676         assert(curop->op_type == OP_RANGE);
4677         Perl_pp_anonlist(aTHX);
4678         break;
4679     case 3:
4680         CLEAR_ERRSV();
4681         o->op_next = old_next;
4682         break;
4683     default:
4684         JMPENV_POP;
4685         PL_warnhook = oldwarnhook;
4686         PL_diehook = olddiehook;
4687         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
4688             ret);
4689     }
4690
4691     JMPENV_POP;
4692     PL_dowarn = oldwarn;
4693     PL_warnhook = oldwarnhook;
4694     PL_diehook = olddiehook;
4695     PL_curcop = old_curcop;
4696
4697     if (cxstack_ix > old_cxix) {
4698         assert(cxstack_ix == old_cxix + 1);
4699         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4700         delete_eval_scope();
4701     }
4702     if (ret)
4703         return o;
4704
4705     OpTYPE_set(o, OP_RV2AV);
4706     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4707     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4708     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4709     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4710
4711     /* replace subtree with an OP_CONST */
4712     curop = ((UNOP*)o)->op_first;
4713     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4714     op_free(curop);
4715
4716     if (AvFILLp(av) != -1)
4717         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4718         {
4719             SvPADTMP_on(*svp);
4720             SvREADONLY_on(*svp);
4721         }
4722     LINKLIST(o);
4723     return list(o);
4724 }
4725
4726 /*
4727 =head1 Optree Manipulation Functions
4728 */
4729
4730 /* List constructors */
4731
4732 /*
4733 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4734
4735 Append an item to the list of ops contained directly within a list-type
4736 op, returning the lengthened list.  C<first> is the list-type op,
4737 and C<last> is the op to append to the list.  C<optype> specifies the
4738 intended opcode for the list.  If C<first> is not already a list of the
4739 right type, it will be upgraded into one.  If either C<first> or C<last>
4740 is null, the other is returned unchanged.
4741
4742 =cut
4743 */
4744
4745 OP *
4746 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4747 {
4748     if (!first)
4749         return last;
4750
4751     if (!last)
4752         return first;
4753
4754     if (first->op_type != (unsigned)type
4755         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4756     {
4757         return newLISTOP(type, 0, first, last);
4758     }
4759
4760     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4761     first->op_flags |= OPf_KIDS;
4762     return first;
4763 }
4764
4765 /*
4766 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4767
4768 Concatenate the lists of ops contained directly within two list-type ops,
4769 returning the combined list.  C<first> and C<last> are the list-type ops
4770 to concatenate.  C<optype> specifies the intended opcode for the list.
4771 If either C<first> or C<last> is not already a list of the right type,
4772 it will be upgraded into one.  If either C<first> or C<last> is null,
4773 the other is returned unchanged.
4774
4775 =cut
4776 */
4777
4778 OP *
4779 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4780 {
4781     if (!first)
4782         return last;
4783
4784     if (!last)
4785         return first;
4786
4787     if (first->op_type != (unsigned)type)
4788         return op_prepend_elem(type, first, last);
4789
4790     if (last->op_type != (unsigned)type)
4791         return op_append_elem(type, first, last);
4792
4793     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4794     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4795     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4796     first->op_flags |= (last->op_flags & OPf_KIDS);
4797
4798     S_op_destroy(aTHX_ last);
4799
4800     return first;
4801 }
4802
4803 /*
4804 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4805
4806 Prepend an item to the list of ops contained directly within a list-type
4807 op, returning the lengthened list.  C<first> is the op to prepend to the
4808 list, and C<last> is the list-type op.  C<optype> specifies the intended
4809 opcode for the list.  If C<last> is not already a list of the right type,
4810 it will be upgraded into one.  If either C<first> or C<last> is null,
4811 the other is returned unchanged.
4812
4813 =cut
4814 */
4815
4816 OP *
4817 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4818 {
4819     if (!first)
4820         return last;
4821
4822     if (!last)
4823         return first;
4824
4825     if (last->op_type == (unsigned)type) {
4826         if (type == OP_LIST) {  /* already a PUSHMARK there */
4827             /* insert 'first' after pushmark */
4828             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4829             if (!(first->op_flags & OPf_PARENS))
4830                 last->op_flags &= ~OPf_PARENS;
4831         }
4832         else
4833             op_sibling_splice(last, NULL, 0, first);
4834         last->op_flags |= OPf_KIDS;
4835         return last;
4836     }
4837
4838     return newLISTOP(type, 0, first, last);
4839 }
4840
4841 /*
4842 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4843
4844 Converts C<o> into a list op if it is not one already, and then converts it
4845 into the specified C<type>, calling its check function, allocating a target if
4846 it needs one, and folding constants.
4847
4848 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4849 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4850 C<op_convert_list> to make it the right type.
4851
4852 =cut
4853 */
4854
4855 OP *
4856 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4857 {
4858     dVAR;
4859     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4860     if (!o || o->op_type != OP_LIST)
4861         o = force_list(o, 0);
4862     else
4863     {
4864         o->op_flags &= ~OPf_WANT;
4865         o->op_private &= ~OPpLVAL_INTRO;
4866     }
4867
4868     if (!(PL_opargs[type] & OA_MARK))
4869         op_null(cLISTOPo->op_first);
4870     else {
4871         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4872         if (kid2 && kid2->op_type == OP_COREARGS) {
4873             op_null(cLISTOPo->op_first);
4874             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4875         }
4876     }
4877
4878     if (type != OP_SPLIT)
4879         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4880          * ck_split() create a real PMOP and leave the op's type as listop
4881          * for now. Otherwise op_free() etc will crash.
4882          */
4883         OpTYPE_set(o, type);
4884
4885     o->op_flags |= flags;
4886     if (flags & OPf_FOLDED)
4887         o->op_folded = 1;
4888
4889     o = CHECKOP(type, o);
4890     if (o->op_type != (unsigned)type)
4891         return o;
4892
4893     return fold_constants(op_integerize(op_std_init(o)));
4894 }
4895
4896 /* Constructors */
4897
4898
4899 /*
4900 =head1 Optree construction
4901
4902 =for apidoc Am|OP *|newNULLLIST
4903
4904 Constructs, checks, and returns a new C<stub> op, which represents an
4905 empty list expression.
4906
4907 =cut
4908 */
4909
4910 OP *
4911 Perl_newNULLLIST(pTHX)
4912 {
4913     return newOP(OP_STUB, 0);
4914 }
4915
4916 /* promote o and any siblings to be a list if its not already; i.e.
4917  *
4918  *  o - A - B
4919  *
4920  * becomes
4921  *
4922  *  list
4923  *    |
4924  *  pushmark - o - A - B
4925  *
4926  * If nullit it true, the list op is nulled.
4927  */
4928
4929 static OP *
4930 S_force_list(pTHX_ OP *o, bool nullit)
4931 {
4932     if (!o || o->op_type != OP_LIST) {
4933         OP *rest = NULL;
4934         if (o) {
4935             /* manually detach any siblings then add them back later */
4936             rest = OpSIBLING(o);
4937             OpLASTSIB_set(o, NULL);
4938         }
4939         o = newLISTOP(OP_LIST, 0, o, NULL);
4940         if (rest)
4941             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4942     }
4943     if (nullit)
4944         op_null(o);
4945     return o;
4946 }
4947
4948 /*
4949 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4950
4951 Constructs, checks, and returns an op of any list type.  C<type> is
4952 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4953 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4954 supply up to two ops to be direct children of the list op; they are
4955 consumed by this function and become part of the constructed op tree.
4956
4957 For most list operators, the check function expects all the kid ops to be
4958 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4959 appropriate.  What you want to do in that case is create an op of type
4960 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4961 See L</op_convert_list> for more information.
4962
4963
4964 =cut
4965 */
4966
4967 OP *
4968 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4969 {
4970     dVAR;
4971     LISTOP *listop;
4972
4973     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4974         || type == OP_CUSTOM);
4975
4976     NewOp(1101, listop, 1, LISTOP);
4977
4978     OpTYPE_set(listop, type);
4979     if (first || last)
4980         flags |= OPf_KIDS;
4981     listop->op_flags = (U8)flags;
4982
4983     if (!last && first)
4984         last = first;
4985     else if (!first && last)
4986         first = last;
4987     else if (first)
4988         OpMORESIB_set(first, last);
4989     listop->op_first = first;
4990     listop->op_last = last;
4991     if (type == OP_LIST) {
4992         OP* const pushop = newOP(OP_PUSHMARK, 0);
4993         OpMORESIB_set(pushop, first);
4994         listop->op_first = pushop;
4995         listop->op_flags |= OPf_KIDS;
4996         if (!last)
4997             listop->op_last = pushop;
4998     }
4999     if (listop->op_last)
5000         OpLASTSIB_set(listop->op_last, (OP*)listop);
5001
5002     return CHECKOP(type, listop);
5003 }
5004
5005 /*
5006 =for apidoc Am|OP *|newOP|I32 type|I32 flags
5007
5008 Constructs, checks, and returns an op of any base type (any type that
5009 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5010 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5011 of C<op_private>.
5012
5013 =cut
5014 */
5015
5016 OP *
5017 Perl_newOP(pTHX_ I32 type, I32 flags)
5018 {
5019     dVAR;
5020     OP *o;
5021
5022     if (type == -OP_ENTEREVAL) {
5023         type = OP_ENTEREVAL;
5024         flags |= OPpEVAL_BYTES<<8;
5025     }
5026
5027     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5028         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5029         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5030         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5031
5032     NewOp(1101, o, 1, OP);
5033     OpTYPE_set(o, type);
5034     o->op_flags = (U8)flags;
5035
5036     o->op_next = o;
5037     o->op_private = (U8)(0 | (flags >> 8));
5038     if (PL_opargs[type] & OA_RETSCALAR)
5039         scalar(o);
5040     if (PL_opargs[type] & OA_TARGET)
5041         o->op_targ = pad_alloc(type, SVs_PADTMP);
5042     return CHECKOP(type, o);
5043 }
5044
5045 /*
5046 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
5047
5048 Constructs, checks, and returns an op of any unary type.  C<type> is
5049 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5050 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5051 bits, the eight bits of C<op_private>, except that the bit with value 1
5052 is automatically set.  C<first> supplies an optional op to be the direct
5053 child of the unary op; it is consumed by this function and become part
5054 of the constructed op tree.
5055
5056 =cut
5057 */
5058
5059 OP *
5060 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5061 {
5062     dVAR;
5063     UNOP *unop;
5064
5065     if (type == -OP_ENTEREVAL) {
5066         type = OP_ENTEREVAL;
5067         flags |= OPpEVAL_BYTES<<8;
5068     }
5069
5070     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5071         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5072         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5073         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5074         || type == OP_SASSIGN
5075         || type == OP_ENTERTRY
5076         || type == OP_CUSTOM
5077         || type == OP_NULL );
5078
5079     if (!first)
5080         first = newOP(OP_STUB, 0);
5081     if (PL_opargs[type] & OA_MARK)
5082         first = force_list(first, 1);
5083
5084     NewOp(1101, unop, 1, UNOP);
5085     OpTYPE_set(unop, type);
5086     unop->op_first = first;
5087     unop->op_flags = (U8)(flags | OPf_KIDS);
5088     unop->op_private = (U8)(1 | (flags >> 8));
5089
5090     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5091         OpLASTSIB_set(first, (OP*)unop);
5092
5093     unop = (UNOP*) CHECKOP(type, unop);
5094     if (unop->op_next)
5095         return (OP*)unop;
5096
5097     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5098 }
5099
5100 /*
5101 =for apidoc newUNOP_AUX
5102
5103 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5104 initialised to C<aux>
5105
5106 =cut
5107 */
5108
5109 OP *
5110 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5111 {
5112     dVAR;
5113     UNOP_AUX *unop;
5114
5115     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5116         || type == OP_CUSTOM);
5117
5118     NewOp(1101, unop, 1, UNOP_AUX);
5119     unop->op_type = (OPCODE)type;
5120     unop->op_ppaddr = PL_ppaddr[type];
5121     unop->op_first = first;
5122     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5123     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5124     unop->op_aux = aux;
5125
5126     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5127         OpLASTSIB_set(first, (OP*)unop);
5128
5129     unop = (UNOP_AUX*) CHECKOP(type, unop);
5130
5131     return op_std_init((OP *) unop);
5132 }
5133
5134 /*
5135 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5136
5137 Constructs, checks, and returns an op of method type with a method name
5138 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5139 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5140 and, shifted up eight bits, the eight bits of C<op_private>, except that
5141 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5142 op which evaluates method name; it is consumed by this function and
5143 become part of the constructed op tree.
5144 Supported optypes: C<OP_METHOD>.
5145
5146 =cut
5147 */
5148
5149 static OP*
5150 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5151     dVAR;
5152     METHOP *methop;
5153
5154     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5155         || type == OP_CUSTOM);
5156
5157     NewOp(1101, methop, 1, METHOP);
5158     if (dynamic_meth) {
5159         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5160         methop->op_flags = (U8)(flags | OPf_KIDS);
5161         methop->op_u.op_first = dynamic_meth;
5162         methop->op_private = (U8)(1 | (flags >> 8));
5163
5164         if (!OpHAS_SIBLING(dynamic_meth))
5165             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5166     }
5167     else {
5168         assert(const_meth);
5169         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5170         methop->op_u.op_meth_sv = const_meth;
5171         methop->op_private = (U8)(0 | (flags >> 8));
5172         methop->op_next = (OP*)methop;
5173     }
5174
5175 #ifdef USE_ITHREADS
5176     methop->op_rclass_targ = 0;
5177 #else
5178     methop->op_rclass_sv = NULL;
5179 #endif
5180
5181     OpTYPE_set(methop, type);
5182     return CHECKOP(type, methop);
5183 }
5184
5185 OP *
5186 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5187     PERL_ARGS_ASSERT_NEWMETHOP;
5188     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5189 }
5190
5191 /*
5192 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5193
5194 Constructs, checks, and returns an op of method type with a constant
5195 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5196 C<op_flags>, and, shifted up eight bits, the eight bits of
5197 C<op_private>.  C<const_meth> supplies a constant method name;
5198 it must be a shared COW string.
5199 Supported optypes: C<OP_METHOD_NAMED>.
5200
5201 =cut
5202 */
5203
5204 OP *
5205 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5206     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5207     return newMETHOP_internal(type, flags, NULL, const_meth);
5208 }
5209
5210 /*
5211 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5212
5213 Constructs, checks, and returns an op of any binary type.  C<type>
5214 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5215 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5216 the eight bits of C<op_private>, except that the bit with value 1 or
5217 2 is automatically set as required.  C<first> and C<last> supply up to
5218 two ops to be the direct children of the binary op; they are consumed
5219 by this function and become part of the constructed op tree.
5220
5221 =cut
5222 */
5223
5224 OP *
5225 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5226 {
5227     dVAR;
5228     BINOP *binop;
5229
5230     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5231         || type == OP_NULL || type == OP_CUSTOM);
5232
5233     NewOp(1101, binop, 1, BINOP);
5234
5235     if (!first)
5236         first = newOP(OP_NULL, 0);
5237
5238     OpTYPE_set(binop, type);
5239     binop->op_first = first;
5240     binop->op_flags = (U8)(flags | OPf_KIDS);
5241     if (!last) {
5242         last = first;
5243         binop->op_private = (U8)(1 | (flags >> 8));
5244     }
5245     else {
5246         binop->op_private = (U8)(2 | (flags >> 8));
5247         OpMORESIB_set(first, last);
5248     }
5249
5250     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5251         OpLASTSIB_set(last, (OP*)binop);
5252
5253     binop->op_last = OpSIBLING(binop->op_first);
5254     if (binop->op_last)
5255         OpLASTSIB_set(binop->op_last, (OP*)binop);
5256
5257     binop = (BINOP*)CHECKOP(type, binop);
5258     if (binop->op_next || binop->op_type != (OPCODE)type)
5259         return (OP*)binop;
5260
5261     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5262 }
5263
5264 static int uvcompare(const void *a, const void *b)
5265     __attribute__nonnull__(1)
5266     __attribute__nonnull__(2)
5267     __attribute__pure__;
5268 static int uvcompare(const void *a, const void *b)
5269 {
5270     if (*((const UV *)a) < (*(const UV *)b))
5271         return -1;
5272     if (*((const UV *)a) > (*(const UV *)b))
5273         return 1;
5274     if (*((const UV *)a+1) < (*(const UV *)b+1))
5275         return -1;
5276     if (*((const UV *)a+1) > (*(const UV *)b+1))
5277         return 1;
5278     return 0;
5279 }
5280
5281 static OP *
5282 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5283 {
5284     SV * const tstr = ((SVOP*)expr)->op_sv;
5285     SV * const rstr =
5286                               ((SVOP*)repl)->op_sv;
5287     STRLEN tlen;
5288     STRLEN rlen;
5289     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5290     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5291     I32 i;
5292     I32 j;
5293     I32 grows = 0;
5294     short *tbl;
5295
5296     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5297     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5298     I32 del              = o->op_private & OPpTRANS_DELETE;
5299     SV* swash;
5300
5301     PERL_ARGS_ASSERT_PMTRANS;
5302
5303     PL_hints |= HINT_BLOCK_SCOPE;
5304
5305     if (SvUTF8(tstr))
5306         o->op_private |= OPpTRANS_FROM_UTF;
5307
5308     if (SvUTF8(rstr))
5309         o->op_private |= OPpTRANS_TO_UTF;
5310
5311     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5312         SV* const listsv = newSVpvs("# comment\n");
5313         SV* transv = NULL;
5314         const U8* tend = t + tlen;
5315         const U8* rend = r + rlen;
5316         STRLEN ulen;
5317         UV tfirst = 1;
5318         UV tlast = 0;
5319         IV tdiff;
5320         STRLEN tcount = 0;
5321         UV rfirst = 1;
5322         UV rlast = 0;
5323         IV rdiff;
5324         STRLEN rcount = 0;
5325         IV diff;
5326         I32 none = 0;
5327         U32 max = 0;
5328         I32 bits;
5329         I32 havefinal = 0;
5330         U32 final = 0;
5331         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5332         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5333         U8* tsave = NULL;
5334         U8* rsave = NULL;
5335         const U32 flags = UTF8_ALLOW_DEFAULT;
5336
5337         if (!from_utf) {
5338             STRLEN len = tlen;
5339             t = tsave = bytes_to_utf8(t, &len);
5340             tend = t + len;
5341         }
5342         if (!to_utf && rlen) {
5343             STRLEN len = rlen;
5344             r = rsave = bytes_to_utf8(r, &len);
5345             rend = r + len;
5346         }
5347
5348 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5349  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5350  * odd.  */
5351
5352         if (complement) {
5353             U8 tmpbuf[UTF8_MAXBYTES+1];
5354             UV *cp;
5355             UV nextmin = 0;
5356             Newx(cp, 2*tlen, UV);
5357             i = 0;
5358             transv = newSVpvs("");
5359             while (t < tend) {
5360                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5361                 t += ulen;
5362                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5363                     t++;
5364                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5365                     t += ulen;
5366                 }
5367                 else {
5368                  cp[2*i+1] = cp[2*i];
5369                 }
5370                 i++;
5371             }
5372             qsort(cp, i, 2*sizeof(UV), uvcompare);
5373             for (j = 0; j < i; j++) {
5374                 UV  val = cp[2*j];
5375                 diff = val - nextmin;
5376                 if (diff > 0) {
5377                     t = uvchr_to_utf8(tmpbuf,nextmin);
5378                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5379                     if (diff > 1) {
5380                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5381                         t = uvchr_to_utf8(tmpbuf, val - 1);
5382                         sv_catpvn(transv, (char *)&range_mark, 1);
5383                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5384                     }
5385                 }
5386                 val = cp[2*j+1];
5387                 if (val >= nextmin)
5388                     nextmin = val + 1;
5389             }
5390             t = uvchr_to_utf8(tmpbuf,nextmin);
5391             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5392             {
5393                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5394                 sv_catpvn(transv, (char *)&range_mark, 1);
5395             }
5396             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5397             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5398             t = (const U8*)SvPVX_const(transv);
5399             tlen = SvCUR(transv);
5400             tend = t + tlen;
5401             Safefree(cp);
5402         }
5403         else if (!rlen && !del) {
5404             r = t; rlen = tlen; rend = tend;
5405         }
5406         if (!squash) {
5407                 if ((!rlen && !del) || t == r ||
5408                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5409                 {
5410                     o->op_private |= OPpTRANS_IDENTICAL;
5411                 }
5412         }
5413
5414         while (t < tend || tfirst <= tlast) {
5415             /* see if we need more "t" chars */
5416             if (tfirst > tlast) {
5417                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5418                 t += ulen;
5419                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5420                     t++;
5421                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5422                     t += ulen;
5423                 }
5424                 else
5425                     tlast = tfirst;
5426             }
5427
5428             /* now see if we need more "r" chars */
5429             if (rfirst > rlast) {
5430                 if (r < rend) {
5431                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5432                     r += ulen;
5433                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5434                         r++;
5435                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5436                         r += ulen;
5437                     }
5438                     else
5439                         rlast = rfirst;
5440                 }
5441                 else {
5442                     if (!havefinal++)
5443                         final = rlast;
5444                     rfirst = rlast = 0xffffffff;
5445                 }
5446             }
5447
5448             /* now see which range will peter out first, if either. */
5449             tdiff = tlast - tfirst;
5450             rdiff = rlast - rfirst;
5451             tcount += tdiff + 1;
5452             rcount += rdiff + 1;
5453
5454             if (tdiff <= rdiff)
5455                 diff = tdiff;
5456             else
5457                 diff = rdiff;
5458
5459             if (rfirst == 0xffffffff) {
5460                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5461                 if (diff > 0)
5462                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5463                                    (long)tfirst, (long)tlast);
5464                 else
5465                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5466             }
5467             else {
5468                 if (diff > 0)
5469                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5470                                    (long)tfirst, (long)(tfirst + diff),
5471                                    (long)rfirst);
5472                 else
5473                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5474                                    (long)tfirst, (long)rfirst);
5475
5476                 if (rfirst + diff > max)
5477                     max = rfirst + diff;
5478                 if (!grows)
5479                     grows = (tfirst < rfirst &&
5480                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5481                 rfirst += diff + 1;
5482             }
5483             tfirst += diff + 1;
5484         }
5485
5486         none = ++max;
5487         if (del)
5488             del = ++max;
5489
5490         if (max > 0xffff)
5491             bits = 32;
5492         else if (max > 0xff)
5493             bits = 16;
5494         else
5495             bits = 8;
5496
5497         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5498 #ifdef USE_ITHREADS
5499         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5500         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5501         PAD_SETSV(cPADOPo->op_padix, swash);
5502         SvPADTMP_on(swash);
5503         SvREADONLY_on(swash);
5504 #else
5505         cSVOPo->op_sv = swash;
5506 #endif
5507         SvREFCNT_dec(listsv);
5508         SvREFCNT_dec(transv);
5509
5510         if (!del && havefinal && rlen)
5511             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5512                            newSVuv((UV)final), 0);
5513
5514         Safefree(tsave);
5515         Safefree(rsave);
5516
5517         tlen = tcount;
5518         rlen = rcount;
5519         if (r < rend)
5520             rlen++;
5521         else if (rlast == 0xffffffff)
5522             rlen = 0;
5523
5524         goto warnins;
5525     }
5526
5527     tbl = (short*)PerlMemShared_calloc(
5528         (o->op_private & OPpTRANS_COMPLEMENT) &&
5529             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5530         sizeof(short));
5531     cPVOPo->op_pv = (char*)tbl;
5532     if (complement) {
5533         for (i = 0; i < (I32)tlen; i++)
5534             tbl[t[i]] = -1;
5535         for (i = 0, j = 0; i < 256; i++) {
5536             if (!tbl[i]) {
5537                 if (j >= (I32)rlen) {
5538                     if (del)
5539                         tbl[i] = -2;
5540                     else if (rlen)
5541                         tbl[i] = r[j-1];
5542                     else
5543                         tbl[i] = (short)i;
5544                 }
5545                 else {
5546                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5547                         grows = 1;
5548                     tbl[i] = r[j++];
5549                 }
5550             }
5551         }
5552         if (!del) {
5553             if (!rlen) {
5554                 j = rlen;
5555                 if (!squash)
5556                     o->op_private |= OPpTRANS_IDENTICAL;
5557             }
5558             else if (j >= (I32)rlen)
5559                 j = rlen - 1;
5560             else {
5561                 tbl = 
5562                     (short *)
5563                     PerlMemShared_realloc(tbl,
5564                                           (0x101+rlen-j) * sizeof(short));
5565                 cPVOPo->op_pv = (char*)tbl;
5566             }
5567             tbl[0x100] = (short)(rlen - j);
5568             for (i=0; i < (I32)rlen - j; i++)
5569                 tbl[0x101+i] = r[j+i];
5570         }
5571     }
5572     else {
5573         if (!rlen && !del) {
5574             r = t; rlen = tlen;
5575             if (!squash)
5576                 o->op_private |= OPpTRANS_IDENTICAL;
5577         }
5578         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5579             o->op_private |= OPpTRANS_IDENTICAL;
5580         }
5581         for (i = 0; i < 256; i++)
5582             tbl[i] = -1;
5583         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5584             if (j >= (I32)rlen) {
5585                 if (del) {
5586                     if (tbl[t[i]] == -1)
5587                         tbl[t[i]] = -2;
5588                     continue;
5589                 }
5590                 --j;
5591             }
5592             if (tbl[t[i]] == -1) {
5593                 if (     UVCHR_IS_INVARIANT(t[i])
5594                     && ! UVCHR_IS_INVARIANT(r[j]))
5595                     grows = 1;
5596                 tbl[t[i]] = r[j];
5597             }
5598         }
5599     }
5600
5601   warnins:
5602     if(del && rlen == tlen) {
5603         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
5604     } else if(rlen > tlen && !complement) {
5605         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5606     }
5607
5608     if (grows)
5609         o->op_private |= OPpTRANS_GROWS;
5610     op_free(expr);
5611     op_free(repl);
5612
5613     return o;
5614 }
5615
5616 /*
5617 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5618
5619 Constructs, checks, and returns an op of any pattern matching type.
5620 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5621 and, shifted up eight bits, the eight bits of C<op_private>.
5622
5623 =cut
5624 */
5625
5626 OP *
5627 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5628 {
5629     dVAR;
5630     PMOP *pmop;
5631
5632     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5633         || type == OP_CUSTOM);
5634
5635     NewOp(1101, pmop, 1, PMOP);
5636     OpTYPE_set(pmop, type);
5637     pmop->op_flags = (U8)flags;
5638     pmop->op_private = (U8)(0 | (flags >> 8));
5639     if (PL_opargs[type] & OA_RETSCALAR)
5640         scalar((OP *)pmop);
5641
5642     if (PL_hints & HINT_RE_TAINT)
5643         pmop->op_pmflags |= PMf_RETAINT;
5644 #ifdef USE_LOCALE_CTYPE
5645     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5646         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5647     }
5648     else
5649 #endif
5650          if (IN_UNI_8_BIT) {
5651         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5652     }
5653     if (PL_hints & HINT_RE_FLAGS) {
5654         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5655          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5656         );
5657         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5658         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5659          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5660         );
5661         if (reflags && SvOK(reflags)) {
5662             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5663         }
5664     }
5665
5666
5667 #ifdef USE_ITHREADS
5668     assert(SvPOK(PL_regex_pad[0]));
5669     if (SvCUR(PL_regex_pad[0])) {
5670         /* Pop off the "packed" IV from the end.  */
5671         SV *const repointer_list = PL_regex_pad[0];
5672         const char *p = SvEND(repointer_list) - sizeof(IV);
5673         const IV offset = *((IV*)p);
5674
5675         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5676
5677         SvEND_set(repointer_list, p);
5678
5679         pmop->op_pmoffset = offset;
5680         /* This slot should be free, so assert this:  */
5681         assert(PL_regex_pad[offset] == &PL_sv_undef);
5682     } else {
5683         SV * const repointer = &PL_sv_undef;
5684         av_push(PL_regex_padav, repointer);
5685         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5686         PL_regex_pad = AvARRAY(PL_regex_padav);
5687     }
5688 #endif
5689
5690     return CHECKOP(type, pmop);
5691 }
5692
5693 static void
5694 S_set_haseval(pTHX)
5695 {
5696     PADOFFSET i = 1;
5697     PL_cv_has_eval = 1;
5698     /* Any pad names in scope are potentially lvalues.  */
5699     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5700         PADNAME *pn = PAD_COMPNAME_SV(i);
5701         if (!pn || !PadnameLEN(pn))
5702             continue;
5703         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5704             S_mark_padname_lvalue(aTHX_ pn);
5705     }
5706 }
5707
5708 /* Given some sort of match op o, and an expression expr containing a
5709  * pattern, either compile expr into a regex and attach it to o (if it's
5710  * constant), or convert expr into a runtime regcomp op sequence (if it's
5711  * not)
5712  *
5713  * Flags currently has 2 bits of meaning:
5714  * 1: isreg indicates that the pattern is part of a regex construct, eg
5715  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5716  * split "pattern", which aren't. In the former case, expr will be a list
5717  * if the pattern contains more than one term (eg /a$b/).
5718  * 2: The pattern is for a split.
5719  *
5720  * When the pattern has been compiled within a new anon CV (for
5721  * qr/(?{...})/ ), then floor indicates the savestack level just before
5722  * the new sub was created
5723  */
5724
5725 OP *
5726 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5727 {
5728     PMOP *pm;
5729     LOGOP *rcop;
5730     I32 repl_has_vars = 0;
5731     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5732     bool is_compiletime;
5733     bool has_code;
5734     bool isreg    = cBOOL(flags & 1);
5735     bool is_split = cBOOL(flags & 2);
5736
5737     PERL_ARGS_ASSERT_PMRUNTIME;
5738
5739     if (is_trans) {
5740         return pmtrans(o, expr, repl);
5741     }
5742
5743     /* find whether we have any runtime or code elements;
5744      * at the same time, temporarily set the op_next of each DO block;
5745      * then when we LINKLIST, this will cause the DO blocks to be excluded
5746      * from the op_next chain (and from having LINKLIST recursively
5747      * applied to them). We fix up the DOs specially later */
5748
5749     is_compiletime = 1;
5750     has_code = 0;
5751     if (expr->op_type == OP_LIST) {
5752         OP *o;
5753         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5754             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5755                 has_code = 1;
5756                 assert(!o->op_next);
5757                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5758                     assert(PL_parser && PL_parser->error_count);
5759                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5760                        the op we were expecting to see, to avoid crashing
5761                        elsewhere.  */
5762                     op_sibling_splice(expr, o, 0,
5763                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5764                 }
5765                 o->op_next = OpSIBLING(o);
5766             }
5767             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5768                 is_compiletime = 0;
5769         }
5770     }
5771     else if (expr->op_type != OP_CONST)
5772         is_compiletime = 0;
5773
5774     LINKLIST(expr);
5775
5776     /* fix up DO blocks; treat each one as a separate little sub;
5777      * also, mark any arrays as LIST/REF */
5778
5779     if (expr->op_type == OP_LIST) {
5780         OP *o;
5781         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5782
5783             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5784                 assert( !(o->op_flags  & OPf_WANT));
5785                 /* push the array rather than its contents. The regex
5786                  * engine will retrieve and join the elements later */
5787                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5788                 continue;
5789             }
5790
5791             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5792                 continue;
5793             o->op_next = NULL; /* undo temporary hack from above */
5794             scalar(o);
5795             LINKLIST(o);
5796             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5797                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5798                 /* skip ENTER */
5799                 assert(leaveop->op_first->op_type == OP_ENTER);
5800                 assert(OpHAS_SIBLING(leaveop->op_first));
5801                 o->op_next = OpSIBLING(leaveop->op_first);
5802                 /* skip leave */
5803                 assert(leaveop->op_flags & OPf_KIDS);
5804                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5805                 leaveop->op_next = NULL; /* stop on last op */
5806                 op_null((OP*)leaveop);
5807             }
5808             else {
5809                 /* skip SCOPE */
5810                 OP *scope = cLISTOPo->op_first;
5811                 assert(scope->op_type == OP_SCOPE);
5812                 assert(scope->op_flags & OPf_KIDS);
5813                 scope->op_next = NULL; /* stop on last op */
5814                 op_null(scope);
5815             }
5816             /* have to peep the DOs individually as we've removed it from
5817              * the op_next chain */
5818             CALL_PEEP(o);
5819             S_prune_chain_head(&(o->op_next));
5820             if (is_compiletime)
5821                 /* runtime finalizes as part of finalizing whole tree */
5822                 finalize_optree(o);
5823         }
5824     }
5825     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5826         assert( !(expr->op_flags  & OPf_WANT));
5827         /* push the array rather than its contents. The regex
5828          * engine will retrieve and join the elements later */
5829         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5830     }
5831
5832     PL_hints |= HINT_BLOCK_SCOPE;
5833     pm = (PMOP*)o;
5834     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5835
5836     if (is_compiletime) {
5837         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5838         regexp_engine const *eng = current_re_engine();
5839
5840         if (is_split) {
5841             /* make engine handle split ' ' specially */
5842             pm->op_pmflags |= PMf_SPLIT;
5843             rx_flags |= RXf_SPLIT;
5844         }
5845
5846         /* Skip compiling if parser found an error for this pattern */
5847         if (pm->op_pmflags & PMf_HAS_ERROR) {
5848             return o;
5849         }
5850
5851         if (!has_code || !eng->op_comp) {
5852             /* compile-time simple constant pattern */
5853
5854             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5855                 /* whoops! we guessed that a qr// had a code block, but we
5856                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5857                  * that isn't required now. Note that we have to be pretty
5858                  * confident that nothing used that CV's pad while the
5859                  * regex was parsed, except maybe op targets for \Q etc.
5860                  * If there were any op targets, though, they should have
5861                  * been stolen by constant folding.
5862                  */
5863 #ifdef DEBUGGING
5864                 SSize_t i = 0;
5865                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5866                 while (++i <= AvFILLp(PL_comppad)) {
5867 #  ifdef USE_PAD_RESET
5868                     /* under USE_PAD_RESET, pad swipe replaces a swiped
5869                      * folded constant with a fresh padtmp */
5870                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5871 #  else
5872                     assert(!PL_curpad[i]);
5873 #  endif
5874                 }
5875 #endif
5876                 /* But we know that one op is using this CV's slab. */
5877                 cv_forget_slab(PL_compcv);
5878                 LEAVE_SCOPE(floor);
5879                 pm->op_pmflags &= ~PMf_HAS_CV;
5880             }
5881
5882             PM_SETRE(pm,
5883                 eng->op_comp
5884                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5885                                         rx_flags, pm->op_pmflags)
5886                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5887                                         rx_flags, pm->op_pmflags)
5888             );
5889             op_free(expr);
5890         }
5891         else {
5892             /* compile-time pattern that includes literal code blocks */
5893             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5894                         rx_flags,
5895                         (pm->op_pmflags |
5896                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5897                     );
5898             PM_SETRE(pm, re);
5899             if (pm->op_pmflags & PMf_HAS_CV) {
5900                 CV *cv;
5901                 /* this QR op (and the anon sub we embed it in) is never
5902                  * actually executed. It's just a placeholder where we can
5903                  * squirrel away expr in op_code_list without the peephole
5904                  * optimiser etc processing it for a second time */
5905                 OP *qr = newPMOP(OP_QR, 0);
5906                 ((PMOP*)qr)->op_code_list = expr;
5907
5908                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5909                 SvREFCNT_inc_simple_void(PL_compcv);
5910                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5911                 ReANY(re)->qr_anoncv = cv;
5912
5913                 /* attach the anon CV to the pad so that
5914                  * pad_fixup_inner_anons() can find it */
5915                 (void)pad_add_anon(cv, o->op_type);
5916                 SvREFCNT_inc_simple_void(cv);
5917             }