c4c9fc0171aadd6bc4b2dcf7591783e943dba070
[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     OPSLOT *slot;
491 #ifdef DEBUGGING
492     size_t savestack_count = 0;
493 #endif
494     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
495     slab2 = slab;
496     do {
497         for (slot = slab2->opslab_first;
498              slot->opslot_next;
499              slot = slot->opslot_next) {
500             if (slot->opslot_op.op_type != OP_FREED
501              && !(slot->opslot_op.op_savefree
502 #ifdef DEBUGGING
503                   && ++savestack_count
504 #endif
505                  )
506             ) {
507                 assert(slot->opslot_op.op_slabbed);
508                 op_free(&slot->opslot_op);
509                 if (slab->opslab_refcnt == 1) goto free;
510             }
511         }
512     } while ((slab2 = slab2->opslab_next));
513     /* > 1 because the CV still holds a reference count. */
514     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
515 #ifdef DEBUGGING
516         assert(savestack_count == slab->opslab_refcnt-1);
517 #endif
518         /* Remove the CV’s reference count. */
519         slab->opslab_refcnt--;
520         return;
521     }
522    free:
523     opslab_free(slab);
524 }
525
526 #ifdef PERL_DEBUG_READONLY_OPS
527 OP *
528 Perl_op_refcnt_inc(pTHX_ OP *o)
529 {
530     if(o) {
531         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532         if (slab && slab->opslab_readonly) {
533             Slab_to_rw(slab);
534             ++o->op_targ;
535             Slab_to_ro(slab);
536         } else {
537             ++o->op_targ;
538         }
539     }
540     return o;
541
542 }
543
544 PADOFFSET
545 Perl_op_refcnt_dec(pTHX_ OP *o)
546 {
547     PADOFFSET result;
548     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
549
550     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
551
552     if (slab && slab->opslab_readonly) {
553         Slab_to_rw(slab);
554         result = --o->op_targ;
555         Slab_to_ro(slab);
556     } else {
557         result = --o->op_targ;
558     }
559     return result;
560 }
561 #endif
562 /*
563  * In the following definition, the ", (OP*)0" is just to make the compiler
564  * think the expression is of the right type: croak actually does a Siglongjmp.
565  */
566 #define CHECKOP(type,o) \
567     ((PL_op_mask && PL_op_mask[type])                           \
568      ? ( op_free((OP*)o),                                       \
569          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
570          (OP*)0 )                                               \
571      : PL_check[type](aTHX_ (OP*)o))
572
573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
574
575 #define OpTYPE_set(o,type) \
576     STMT_START {                                \
577         o->op_type = (OPCODE)type;              \
578         o->op_ppaddr = PL_ppaddr[type];         \
579     } STMT_END
580
581 STATIC OP *
582 S_no_fh_allowed(pTHX_ OP *o)
583 {
584     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
585
586     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
587                  OP_DESC(o)));
588     return o;
589 }
590
591 STATIC OP *
592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
593 {
594     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
596     return o;
597 }
598  
599 STATIC OP *
600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
601 {
602     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
603
604     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
605     return o;
606 }
607
608 STATIC void
609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
610 {
611     PERL_ARGS_ASSERT_BAD_TYPE_PV;
612
613     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
614                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
615 }
616
617 /* remove flags var, its unused in all callers, move to to right end since gv
618   and kid are always the same */
619 STATIC void
620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
621 {
622     SV * const namesv = cv_name((CV *)gv, NULL, 0);
623     PERL_ARGS_ASSERT_BAD_TYPE_GV;
624  
625     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
626                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
627 }
628
629 STATIC void
630 S_no_bareword_allowed(pTHX_ OP *o)
631 {
632     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
633
634     qerror(Perl_mess(aTHX_
635                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
636                      SVfARG(cSVOPo_sv)));
637     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
638 }
639
640 /* "register" allocation */
641
642 PADOFFSET
643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
644 {
645     PADOFFSET off;
646     const bool is_our = (PL_parser->in_my == KEY_our);
647
648     PERL_ARGS_ASSERT_ALLOCMY;
649
650     if (flags & ~SVf_UTF8)
651         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
652                    (UV)flags);
653
654     /* complain about "my $<special_var>" etc etc */
655     if (   len
656         && !(  is_our
657             || isALPHA(name[1])
658             || (   (flags & SVf_UTF8)
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     U8 want;
1869     SSize_t defer_stack_alloc = 0;
1870     SSize_t defer_ix = -1;
1871     OP **defer_stack = NULL;
1872     OP *o = arg;
1873
1874     PERL_ARGS_ASSERT_SCALARVOID;
1875
1876     do {
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
4636     list(o);
4637     if (PL_parser && PL_parser->error_count)
4638         return o;               /* Don't attempt to run with errors */
4639
4640     curop = LINKLIST(o);
4641     old_next = o->op_next;
4642     o->op_next = 0;
4643     CALL_PEEP(curop);
4644     S_prune_chain_head(&curop);
4645     PL_op = curop;
4646
4647     old_cxix = cxstack_ix;
4648     create_eval_scope(NULL, G_FAKINGEVAL);
4649
4650     old_curcop = PL_curcop;
4651     StructCopy(old_curcop, &not_compiling, COP);
4652     PL_curcop = &not_compiling;
4653     /* The above ensures that we run with all the correct hints of the
4654        current COP, but that IN_PERL_RUNTIME is true. */
4655     assert(IN_PERL_RUNTIME);
4656     PL_warnhook = PERL_WARNHOOK_FATAL;
4657     PL_diehook  = NULL;
4658     JMPENV_PUSH(ret);
4659
4660     /* Effective $^W=1.  */
4661     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4662         PL_dowarn |= G_WARN_ON;
4663
4664     switch (ret) {
4665     case 0:
4666         Perl_pp_pushmark(aTHX);
4667         CALLRUNOPS(aTHX);
4668         PL_op = curop;
4669         assert (!(curop->op_flags & OPf_SPECIAL));
4670         assert(curop->op_type == OP_RANGE);
4671         Perl_pp_anonlist(aTHX);
4672         break;
4673     case 3:
4674         CLEAR_ERRSV();
4675         o->op_next = old_next;
4676         break;
4677     default:
4678         JMPENV_POP;
4679         PL_warnhook = oldwarnhook;
4680         PL_diehook = olddiehook;
4681         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
4682             ret);
4683     }
4684
4685     JMPENV_POP;
4686     PL_dowarn = oldwarn;
4687     PL_warnhook = oldwarnhook;
4688     PL_diehook = olddiehook;
4689     PL_curcop = old_curcop;
4690
4691     if (cxstack_ix > old_cxix) {
4692         assert(cxstack_ix == old_cxix + 1);
4693         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4694         delete_eval_scope();
4695     }
4696     if (ret)
4697         return o;
4698
4699     OpTYPE_set(o, OP_RV2AV);
4700     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4701     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4702     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4703     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4704
4705     /* replace subtree with an OP_CONST */
4706     curop = ((UNOP*)o)->op_first;
4707     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4708     op_free(curop);
4709
4710     if (AvFILLp(av) != -1)
4711         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4712         {
4713             SvPADTMP_on(*svp);
4714             SvREADONLY_on(*svp);
4715         }
4716     LINKLIST(o);
4717     return list(o);
4718 }
4719
4720 /*
4721 =head1 Optree Manipulation Functions
4722 */
4723
4724 /* List constructors */
4725
4726 /*
4727 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4728
4729 Append an item to the list of ops contained directly within a list-type
4730 op, returning the lengthened list.  C<first> is the list-type op,
4731 and C<last> is the op to append to the list.  C<optype> specifies the
4732 intended opcode for the list.  If C<first> is not already a list of the
4733 right type, it will be upgraded into one.  If either C<first> or C<last>
4734 is null, the other is returned unchanged.
4735
4736 =cut
4737 */
4738
4739 OP *
4740 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4741 {
4742     if (!first)
4743         return last;
4744
4745     if (!last)
4746         return first;
4747
4748     if (first->op_type != (unsigned)type
4749         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4750     {
4751         return newLISTOP(type, 0, first, last);
4752     }
4753
4754     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4755     first->op_flags |= OPf_KIDS;
4756     return first;
4757 }
4758
4759 /*
4760 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4761
4762 Concatenate the lists of ops contained directly within two list-type ops,
4763 returning the combined list.  C<first> and C<last> are the list-type ops
4764 to concatenate.  C<optype> specifies the intended opcode for the list.
4765 If either C<first> or C<last> is not already a list of the right type,
4766 it will be upgraded into one.  If either C<first> or C<last> is null,
4767 the other is returned unchanged.
4768
4769 =cut
4770 */
4771
4772 OP *
4773 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4774 {
4775     if (!first)
4776         return last;
4777
4778     if (!last)
4779         return first;
4780
4781     if (first->op_type != (unsigned)type)
4782         return op_prepend_elem(type, first, last);
4783
4784     if (last->op_type != (unsigned)type)
4785         return op_append_elem(type, first, last);
4786
4787     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4788     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4789     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4790     first->op_flags |= (last->op_flags & OPf_KIDS);
4791
4792     S_op_destroy(aTHX_ last);
4793
4794     return first;
4795 }
4796
4797 /*
4798 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4799
4800 Prepend an item to the list of ops contained directly within a list-type
4801 op, returning the lengthened list.  C<first> is the op to prepend to the
4802 list, and C<last> is the list-type op.  C<optype> specifies the intended
4803 opcode for the list.  If C<last> is not already a list of the right type,
4804 it will be upgraded into one.  If either C<first> or C<last> is null,
4805 the other is returned unchanged.
4806
4807 =cut
4808 */
4809
4810 OP *
4811 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4812 {
4813     if (!first)
4814         return last;
4815
4816     if (!last)
4817         return first;
4818
4819     if (last->op_type == (unsigned)type) {
4820         if (type == OP_LIST) {  /* already a PUSHMARK there */
4821             /* insert 'first' after pushmark */
4822             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4823             if (!(first->op_flags & OPf_PARENS))
4824                 last->op_flags &= ~OPf_PARENS;
4825         }
4826         else
4827             op_sibling_splice(last, NULL, 0, first);
4828         last->op_flags |= OPf_KIDS;
4829         return last;
4830     }
4831
4832     return newLISTOP(type, 0, first, last);
4833 }
4834
4835 /*
4836 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4837
4838 Converts C<o> into a list op if it is not one already, and then converts it
4839 into the specified C<type>, calling its check function, allocating a target if
4840 it needs one, and folding constants.
4841
4842 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4843 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4844 C<op_convert_list> to make it the right type.
4845
4846 =cut
4847 */
4848
4849 OP *
4850 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4851 {
4852     dVAR;
4853     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4854     if (!o || o->op_type != OP_LIST)
4855         o = force_list(o, 0);
4856     else
4857     {
4858         o->op_flags &= ~OPf_WANT;
4859         o->op_private &= ~OPpLVAL_INTRO;
4860     }
4861
4862     if (!(PL_opargs[type] & OA_MARK))
4863         op_null(cLISTOPo->op_first);
4864     else {
4865         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4866         if (kid2 && kid2->op_type == OP_COREARGS) {
4867             op_null(cLISTOPo->op_first);
4868             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4869         }
4870     }
4871
4872     if (type != OP_SPLIT)
4873         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4874          * ck_split() create a real PMOP and leave the op's type as listop
4875          * for now. Otherwise op_free() etc will crash.
4876          */
4877         OpTYPE_set(o, type);
4878
4879     o->op_flags |= flags;
4880     if (flags & OPf_FOLDED)
4881         o->op_folded = 1;
4882
4883     o = CHECKOP(type, o);
4884     if (o->op_type != (unsigned)type)
4885         return o;
4886
4887     return fold_constants(op_integerize(op_std_init(o)));
4888 }
4889
4890 /* Constructors */
4891
4892
4893 /*
4894 =head1 Optree construction
4895
4896 =for apidoc Am|OP *|newNULLLIST
4897
4898 Constructs, checks, and returns a new C<stub> op, which represents an
4899 empty list expression.
4900
4901 =cut
4902 */
4903
4904 OP *
4905 Perl_newNULLLIST(pTHX)
4906 {
4907     return newOP(OP_STUB, 0);
4908 }
4909
4910 /* promote o and any siblings to be a list if its not already; i.e.
4911  *
4912  *  o - A - B
4913  *
4914  * becomes
4915  *
4916  *  list
4917  *    |
4918  *  pushmark - o - A - B
4919  *
4920  * If nullit it true, the list op is nulled.
4921  */
4922
4923 static OP *
4924 S_force_list(pTHX_ OP *o, bool nullit)
4925 {
4926     if (!o || o->op_type != OP_LIST) {
4927         OP *rest = NULL;
4928         if (o) {
4929             /* manually detach any siblings then add them back later */
4930             rest = OpSIBLING(o);
4931             OpLASTSIB_set(o, NULL);
4932         }
4933         o = newLISTOP(OP_LIST, 0, o, NULL);
4934         if (rest)
4935             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4936     }
4937     if (nullit)
4938         op_null(o);
4939     return o;
4940 }
4941
4942 /*
4943 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4944
4945 Constructs, checks, and returns an op of any list type.  C<type> is
4946 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4947 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4948 supply up to two ops to be direct children of the list op; they are
4949 consumed by this function and become part of the constructed op tree.
4950
4951 For most list operators, the check function expects all the kid ops to be
4952 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4953 appropriate.  What you want to do in that case is create an op of type
4954 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4955 See L</op_convert_list> for more information.
4956
4957
4958 =cut
4959 */
4960
4961 OP *
4962 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4963 {
4964     dVAR;
4965     LISTOP *listop;
4966
4967     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4968         || type == OP_CUSTOM);
4969
4970     NewOp(1101, listop, 1, LISTOP);
4971
4972     OpTYPE_set(listop, type);
4973     if (first || last)
4974         flags |= OPf_KIDS;
4975     listop->op_flags = (U8)flags;
4976
4977     if (!last && first)
4978         last = first;
4979     else if (!first && last)
4980         first = last;
4981     else if (first)
4982         OpMORESIB_set(first, last);
4983     listop->op_first = first;
4984     listop->op_last = last;
4985     if (type == OP_LIST) {
4986         OP* const pushop = newOP(OP_PUSHMARK, 0);
4987         OpMORESIB_set(pushop, first);
4988         listop->op_first = pushop;
4989         listop->op_flags |= OPf_KIDS;
4990         if (!last)
4991             listop->op_last = pushop;
4992     }
4993     if (listop->op_last)
4994         OpLASTSIB_set(listop->op_last, (OP*)listop);
4995
4996     return CHECKOP(type, listop);
4997 }
4998
4999 /*
5000 =for apidoc Am|OP *|newOP|I32 type|I32 flags
5001
5002 Constructs, checks, and returns an op of any base type (any type that
5003 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5004 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5005 of C<op_private>.
5006
5007 =cut
5008 */
5009
5010 OP *
5011 Perl_newOP(pTHX_ I32 type, I32 flags)
5012 {
5013     dVAR;
5014     OP *o;
5015
5016     if (type == -OP_ENTEREVAL) {
5017         type = OP_ENTEREVAL;
5018         flags |= OPpEVAL_BYTES<<8;
5019     }
5020
5021     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5022         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5023         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5024         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5025
5026     NewOp(1101, o, 1, OP);
5027     OpTYPE_set(o, type);
5028     o->op_flags = (U8)flags;
5029
5030     o->op_next = o;
5031     o->op_private = (U8)(0 | (flags >> 8));
5032     if (PL_opargs[type] & OA_RETSCALAR)
5033         scalar(o);
5034     if (PL_opargs[type] & OA_TARGET)
5035         o->op_targ = pad_alloc(type, SVs_PADTMP);
5036     return CHECKOP(type, o);
5037 }
5038
5039 /*
5040 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
5041
5042 Constructs, checks, and returns an op of any unary type.  C<type> is
5043 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5044 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5045 bits, the eight bits of C<op_private>, except that the bit with value 1
5046 is automatically set.  C<first> supplies an optional op to be the direct
5047 child of the unary op; it is consumed by this function and become part
5048 of the constructed op tree.
5049
5050 =cut
5051 */
5052
5053 OP *
5054 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5055 {
5056     dVAR;
5057     UNOP *unop;
5058
5059     if (type == -OP_ENTEREVAL) {
5060         type = OP_ENTEREVAL;
5061         flags |= OPpEVAL_BYTES<<8;
5062     }
5063
5064     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5065         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5066         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5067         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5068         || type == OP_SASSIGN
5069         || type == OP_ENTERTRY
5070         || type == OP_CUSTOM
5071         || type == OP_NULL );
5072
5073     if (!first)
5074         first = newOP(OP_STUB, 0);
5075     if (PL_opargs[type] & OA_MARK)
5076         first = force_list(first, 1);
5077
5078     NewOp(1101, unop, 1, UNOP);
5079     OpTYPE_set(unop, type);
5080     unop->op_first = first;
5081     unop->op_flags = (U8)(flags | OPf_KIDS);
5082     unop->op_private = (U8)(1 | (flags >> 8));
5083
5084     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5085         OpLASTSIB_set(first, (OP*)unop);
5086
5087     unop = (UNOP*) CHECKOP(type, unop);
5088     if (unop->op_next)
5089         return (OP*)unop;
5090
5091     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5092 }
5093
5094 /*
5095 =for apidoc newUNOP_AUX
5096
5097 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5098 initialised to C<aux>
5099
5100 =cut
5101 */
5102
5103 OP *
5104 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5105 {
5106     dVAR;
5107     UNOP_AUX *unop;
5108
5109     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5110         || type == OP_CUSTOM);
5111
5112     NewOp(1101, unop, 1, UNOP_AUX);
5113     unop->op_type = (OPCODE)type;
5114     unop->op_ppaddr = PL_ppaddr[type];
5115     unop->op_first = first;
5116     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5117     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5118     unop->op_aux = aux;
5119
5120     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5121         OpLASTSIB_set(first, (OP*)unop);
5122
5123     unop = (UNOP_AUX*) CHECKOP(type, unop);
5124
5125     return op_std_init((OP *) unop);
5126 }
5127
5128 /*
5129 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5130
5131 Constructs, checks, and returns an op of method type with a method name
5132 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5133 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5134 and, shifted up eight bits, the eight bits of C<op_private>, except that
5135 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5136 op which evaluates method name; it is consumed by this function and
5137 become part of the constructed op tree.
5138 Supported optypes: C<OP_METHOD>.
5139
5140 =cut
5141 */
5142
5143 static OP*
5144 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5145     dVAR;
5146     METHOP *methop;
5147
5148     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5149         || type == OP_CUSTOM);
5150
5151     NewOp(1101, methop, 1, METHOP);
5152     if (dynamic_meth) {
5153         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5154         methop->op_flags = (U8)(flags | OPf_KIDS);
5155         methop->op_u.op_first = dynamic_meth;
5156         methop->op_private = (U8)(1 | (flags >> 8));
5157
5158         if (!OpHAS_SIBLING(dynamic_meth))
5159             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5160     }
5161     else {
5162         assert(const_meth);
5163         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5164         methop->op_u.op_meth_sv = const_meth;
5165         methop->op_private = (U8)(0 | (flags >> 8));
5166         methop->op_next = (OP*)methop;
5167     }
5168
5169 #ifdef USE_ITHREADS
5170     methop->op_rclass_targ = 0;
5171 #else
5172     methop->op_rclass_sv = NULL;
5173 #endif
5174
5175     OpTYPE_set(methop, type);
5176     return CHECKOP(type, methop);
5177 }
5178
5179 OP *
5180 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5181     PERL_ARGS_ASSERT_NEWMETHOP;
5182     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5183 }
5184
5185 /*
5186 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5187
5188 Constructs, checks, and returns an op of method type with a constant
5189 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5190 C<op_flags>, and, shifted up eight bits, the eight bits of
5191 C<op_private>.  C<const_meth> supplies a constant method name;
5192 it must be a shared COW string.
5193 Supported optypes: C<OP_METHOD_NAMED>.
5194
5195 =cut
5196 */
5197
5198 OP *
5199 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5200     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5201     return newMETHOP_internal(type, flags, NULL, const_meth);
5202 }
5203
5204 /*
5205 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5206
5207 Constructs, checks, and returns an op of any binary type.  C<type>
5208 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5209 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5210 the eight bits of C<op_private>, except that the bit with value 1 or
5211 2 is automatically set as required.  C<first> and C<last> supply up to
5212 two ops to be the direct children of the binary op; they are consumed
5213 by this function and become part of the constructed op tree.
5214
5215 =cut
5216 */
5217
5218 OP *
5219 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5220 {
5221     dVAR;
5222     BINOP *binop;
5223
5224     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5225         || type == OP_NULL || type == OP_CUSTOM);
5226
5227     NewOp(1101, binop, 1, BINOP);
5228
5229     if (!first)
5230         first = newOP(OP_NULL, 0);
5231
5232     OpTYPE_set(binop, type);
5233     binop->op_first = first;
5234     binop->op_flags = (U8)(flags | OPf_KIDS);
5235     if (!last) {
5236         last = first;
5237         binop->op_private = (U8)(1 | (flags >> 8));
5238     }
5239     else {
5240         binop->op_private = (U8)(2 | (flags >> 8));
5241         OpMORESIB_set(first, last);
5242     }
5243
5244     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5245         OpLASTSIB_set(last, (OP*)binop);
5246
5247     binop->op_last = OpSIBLING(binop->op_first);
5248     if (binop->op_last)
5249         OpLASTSIB_set(binop->op_last, (OP*)binop);
5250
5251     binop = (BINOP*)CHECKOP(type, binop);
5252     if (binop->op_next || binop->op_type != (OPCODE)type)
5253         return (OP*)binop;
5254
5255     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5256 }
5257
5258 static int uvcompare(const void *a, const void *b)
5259     __attribute__nonnull__(1)
5260     __attribute__nonnull__(2)
5261     __attribute__pure__;
5262 static int uvcompare(const void *a, const void *b)
5263 {
5264     if (*((const UV *)a) < (*(const UV *)b))
5265         return -1;
5266     if (*((const UV *)a) > (*(const UV *)b))
5267         return 1;
5268     if (*((const UV *)a+1) < (*(const UV *)b+1))
5269         return -1;
5270     if (*((const UV *)a+1) > (*(const UV *)b+1))
5271         return 1;
5272     return 0;
5273 }
5274
5275 static OP *
5276 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5277 {
5278     SV * const tstr = ((SVOP*)expr)->op_sv;
5279     SV * const rstr =
5280                               ((SVOP*)repl)->op_sv;
5281     STRLEN tlen;
5282     STRLEN rlen;
5283     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5284     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5285     I32 i;
5286     I32 j;
5287     I32 grows = 0;
5288     short *tbl;
5289
5290     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5291     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5292     I32 del              = o->op_private & OPpTRANS_DELETE;
5293     SV* swash;
5294
5295     PERL_ARGS_ASSERT_PMTRANS;
5296
5297     PL_hints |= HINT_BLOCK_SCOPE;
5298
5299     if (SvUTF8(tstr))
5300         o->op_private |= OPpTRANS_FROM_UTF;
5301
5302     if (SvUTF8(rstr))
5303         o->op_private |= OPpTRANS_TO_UTF;
5304
5305     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5306         SV* const listsv = newSVpvs("# comment\n");
5307         SV* transv = NULL;
5308         const U8* tend = t + tlen;
5309         const U8* rend = r + rlen;
5310         STRLEN ulen;
5311         UV tfirst = 1;
5312         UV tlast = 0;
5313         IV tdiff;
5314         STRLEN tcount = 0;
5315         UV rfirst = 1;
5316         UV rlast = 0;
5317         IV rdiff;
5318         STRLEN rcount = 0;
5319         IV diff;
5320         I32 none = 0;
5321         U32 max = 0;
5322         I32 bits;
5323         I32 havefinal = 0;
5324         U32 final = 0;
5325         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5326         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5327         U8* tsave = NULL;
5328         U8* rsave = NULL;
5329         const U32 flags = UTF8_ALLOW_DEFAULT;
5330
5331         if (!from_utf) {
5332             STRLEN len = tlen;
5333             t = tsave = bytes_to_utf8(t, &len);
5334             tend = t + len;
5335         }
5336         if (!to_utf && rlen) {
5337             STRLEN len = rlen;
5338             r = rsave = bytes_to_utf8(r, &len);
5339             rend = r + len;
5340         }
5341
5342 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5343  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5344  * odd.  */
5345
5346         if (complement) {
5347             U8 tmpbuf[UTF8_MAXBYTES+1];
5348             UV *cp;
5349             UV nextmin = 0;
5350             Newx(cp, 2*tlen, UV);
5351             i = 0;
5352             transv = newSVpvs("");
5353             while (t < tend) {
5354                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5355                 t += ulen;
5356                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5357                     t++;
5358                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5359                     t += ulen;
5360                 }
5361                 else {
5362                  cp[2*i+1] = cp[2*i];
5363                 }
5364                 i++;
5365             }
5366             qsort(cp, i, 2*sizeof(UV), uvcompare);
5367             for (j = 0; j < i; j++) {
5368                 UV  val = cp[2*j];
5369                 diff = val - nextmin;
5370                 if (diff > 0) {
5371                     t = uvchr_to_utf8(tmpbuf,nextmin);
5372                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5373                     if (diff > 1) {
5374                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5375                         t = uvchr_to_utf8(tmpbuf, val - 1);
5376                         sv_catpvn(transv, (char *)&range_mark, 1);
5377                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5378                     }
5379                 }
5380                 val = cp[2*j+1];
5381                 if (val >= nextmin)
5382                     nextmin = val + 1;
5383             }
5384             t = uvchr_to_utf8(tmpbuf,nextmin);
5385             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5386             {
5387                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5388                 sv_catpvn(transv, (char *)&range_mark, 1);
5389             }
5390             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5391             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5392             t = (const U8*)SvPVX_const(transv);
5393             tlen = SvCUR(transv);
5394             tend = t + tlen;
5395             Safefree(cp);
5396         }
5397         else if (!rlen && !del) {
5398             r = t; rlen = tlen; rend = tend;
5399         }
5400         if (!squash) {
5401                 if ((!rlen && !del) || t == r ||
5402                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5403                 {
5404                     o->op_private |= OPpTRANS_IDENTICAL;
5405                 }
5406         }
5407
5408         while (t < tend || tfirst <= tlast) {
5409             /* see if we need more "t" chars */
5410             if (tfirst > tlast) {
5411                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5412                 t += ulen;
5413                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5414                     t++;
5415                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5416                     t += ulen;
5417                 }
5418                 else
5419                     tlast = tfirst;
5420             }
5421
5422             /* now see if we need more "r" chars */
5423             if (rfirst > rlast) {
5424                 if (r < rend) {
5425                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5426                     r += ulen;
5427                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5428                         r++;
5429                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5430                         r += ulen;
5431                     }
5432                     else
5433                         rlast = rfirst;
5434                 }
5435                 else {
5436                     if (!havefinal++)
5437                         final = rlast;
5438                     rfirst = rlast = 0xffffffff;
5439                 }
5440             }
5441
5442             /* now see which range will peter out first, if either. */
5443             tdiff = tlast - tfirst;
5444             rdiff = rlast - rfirst;
5445             tcount += tdiff + 1;
5446             rcount += rdiff + 1;
5447
5448             if (tdiff <= rdiff)
5449                 diff = tdiff;
5450             else
5451                 diff = rdiff;
5452
5453             if (rfirst == 0xffffffff) {
5454                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5455                 if (diff > 0)
5456                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5457                                    (long)tfirst, (long)tlast);
5458                 else
5459                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5460             }
5461             else {
5462                 if (diff > 0)
5463                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5464                                    (long)tfirst, (long)(tfirst + diff),
5465                                    (long)rfirst);
5466                 else
5467                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5468                                    (long)tfirst, (long)rfirst);
5469
5470                 if (rfirst + diff > max)
5471                     max = rfirst + diff;
5472                 if (!grows)
5473                     grows = (tfirst < rfirst &&
5474                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5475                 rfirst += diff + 1;
5476             }
5477             tfirst += diff + 1;
5478         }
5479
5480         none = ++max;
5481         if (del)
5482             del = ++max;
5483
5484         if (max > 0xffff)
5485             bits = 32;
5486         else if (max > 0xff)
5487             bits = 16;
5488         else
5489             bits = 8;
5490
5491         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5492 #ifdef USE_ITHREADS
5493         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5494         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5495         PAD_SETSV(cPADOPo->op_padix, swash);
5496         SvPADTMP_on(swash);
5497         SvREADONLY_on(swash);
5498 #else
5499         cSVOPo->op_sv = swash;
5500 #endif
5501         SvREFCNT_dec(listsv);
5502         SvREFCNT_dec(transv);
5503
5504         if (!del && havefinal && rlen)
5505             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5506                            newSVuv((UV)final), 0);
5507
5508         Safefree(tsave);
5509         Safefree(rsave);
5510
5511         tlen = tcount;
5512         rlen = rcount;
5513         if (r < rend)
5514             rlen++;
5515         else if (rlast == 0xffffffff)
5516             rlen = 0;
5517
5518         goto warnins;
5519     }
5520
5521     tbl = (short*)PerlMemShared_calloc(
5522         (o->op_private & OPpTRANS_COMPLEMENT) &&
5523             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5524         sizeof(short));
5525     cPVOPo->op_pv = (char*)tbl;
5526     if (complement) {
5527         for (i = 0; i < (I32)tlen; i++)
5528             tbl[t[i]] = -1;
5529         for (i = 0, j = 0; i < 256; i++) {
5530             if (!tbl[i]) {
5531                 if (j >= (I32)rlen) {
5532                     if (del)
5533                         tbl[i] = -2;
5534                     else if (rlen)
5535                         tbl[i] = r[j-1];
5536                     else
5537                         tbl[i] = (short)i;
5538                 }
5539                 else {
5540                     if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5541                         grows = 1;
5542                     tbl[i] = r[j++];
5543                 }
5544             }
5545         }
5546         if (!del) {
5547             if (!rlen) {
5548                 j = rlen;
5549                 if (!squash)
5550                     o->op_private |= OPpTRANS_IDENTICAL;
5551             }
5552             else if (j >= (I32)rlen)
5553                 j = rlen - 1;
5554             else {
5555                 tbl = 
5556                     (short *)
5557                     PerlMemShared_realloc(tbl,
5558                                           (0x101+rlen-j) * sizeof(short));
5559                 cPVOPo->op_pv = (char*)tbl;
5560             }
5561             tbl[0x100] = (short)(rlen - j);
5562             for (i=0; i < (I32)rlen - j; i++)
5563                 tbl[0x101+i] = r[j+i];
5564         }
5565     }
5566     else {
5567         if (!rlen && !del) {
5568             r = t; rlen = tlen;
5569             if (!squash)
5570                 o->op_private |= OPpTRANS_IDENTICAL;
5571         }
5572         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5573             o->op_private |= OPpTRANS_IDENTICAL;
5574         }
5575         for (i = 0; i < 256; i++)
5576             tbl[i] = -1;
5577         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5578             if (j >= (I32)rlen) {
5579                 if (del) {
5580                     if (tbl[t[i]] == -1)
5581                         tbl[t[i]] = -2;
5582                     continue;
5583                 }
5584                 --j;
5585             }
5586             if (tbl[t[i]] == -1) {
5587                 if (     UVCHR_IS_INVARIANT(t[i])
5588                     && ! UVCHR_IS_INVARIANT(r[j]))
5589                     grows = 1;
5590                 tbl[t[i]] = r[j];
5591             }
5592         }
5593     }
5594
5595   warnins:
5596     if(del && rlen == tlen) {
5597         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
5598     } else if(rlen > tlen && !complement) {
5599         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5600     }
5601
5602     if (grows)
5603         o->op_private |= OPpTRANS_GROWS;
5604     op_free(expr);
5605     op_free(repl);
5606
5607     return o;
5608 }
5609
5610 /*
5611 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5612
5613 Constructs, checks, and returns an op of any pattern matching type.
5614 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5615 and, shifted up eight bits, the eight bits of C<op_private>.
5616
5617 =cut
5618 */
5619
5620 OP *
5621 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5622 {
5623     dVAR;
5624     PMOP *pmop;
5625
5626     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5627         || type == OP_CUSTOM);
5628
5629     NewOp(1101, pmop, 1, PMOP);
5630     OpTYPE_set(pmop, type);
5631     pmop->op_flags = (U8)flags;
5632     pmop->op_private = (U8)(0 | (flags >> 8));
5633     if (PL_opargs[type] & OA_RETSCALAR)
5634         scalar((OP *)pmop);
5635
5636     if (PL_hints & HINT_RE_TAINT)
5637         pmop->op_pmflags |= PMf_RETAINT;
5638 #ifdef USE_LOCALE_CTYPE
5639     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5640         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5641     }
5642     else
5643 #endif
5644          if (IN_UNI_8_BIT) {
5645         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5646     }
5647     if (PL_hints & HINT_RE_FLAGS) {
5648         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5649          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5650         );
5651         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5652         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5653          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5654         );
5655         if (reflags && SvOK(reflags)) {
5656             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5657         }
5658     }
5659
5660
5661 #ifdef USE_ITHREADS
5662     assert(SvPOK(PL_regex_pad[0]));
5663     if (SvCUR(PL_regex_pad[0])) {
5664         /* Pop off the "packed" IV from the end.  */
5665         SV *const repointer_list = PL_regex_pad[0];
5666         const char *p = SvEND(repointer_list) - sizeof(IV);
5667         const IV offset = *((IV*)p);
5668
5669         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5670
5671         SvEND_set(repointer_list, p);
5672
5673         pmop->op_pmoffset = offset;
5674         /* This slot should be free, so assert this:  */
5675         assert(PL_regex_pad[offset] == &PL_sv_undef);
5676     } else {
5677         SV * const repointer = &PL_sv_undef;
5678         av_push(PL_regex_padav, repointer);
5679         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5680         PL_regex_pad = AvARRAY(PL_regex_padav);
5681     }
5682 #endif
5683
5684     return CHECKOP(type, pmop);
5685 }
5686
5687 static void
5688 S_set_haseval(pTHX)
5689 {
5690     PADOFFSET i = 1;
5691     PL_cv_has_eval = 1;
5692     /* Any pad names in scope are potentially lvalues.  */
5693     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5694         PADNAME *pn = PAD_COMPNAME_SV(i);
5695         if (!pn || !PadnameLEN(pn))
5696             continue;
5697         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5698             S_mark_padname_lvalue(aTHX_ pn);
5699     }
5700 }
5701
5702 /* Given some sort of match op o, and an expression expr containing a
5703  * pattern, either compile expr into a regex and attach it to o (if it's
5704  * constant), or convert expr into a runtime regcomp op sequence (if it's
5705  * not)
5706  *
5707  * Flags currently has 2 bits of meaning:
5708  * 1: isreg indicates that the pattern is part of a regex construct, eg
5709  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5710  * split "pattern", which aren't. In the former case, expr will be a list
5711  * if the pattern contains more than one term (eg /a$b/).
5712  * 2: The pattern is for a split.
5713  *
5714  * When the pattern has been compiled within a new anon CV (for
5715  * qr/(?{...})/ ), then floor indicates the savestack level just before
5716  * the new sub was created
5717  */
5718
5719 OP *
5720 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5721 {
5722     PMOP *pm;
5723     LOGOP *rcop;
5724     I32 repl_has_vars = 0;
5725     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5726     bool is_compiletime;
5727     bool has_code;
5728     bool isreg    = cBOOL(flags & 1);
5729     bool is_split = cBOOL(flags & 2);
5730
5731     PERL_ARGS_ASSERT_PMRUNTIME;
5732
5733     if (is_trans) {
5734         return pmtrans(o, expr, repl);
5735     }
5736
5737     /* find whether we have any runtime or code elements;
5738      * at the same time, temporarily set the op_next of each DO block;
5739      * then when we LINKLIST, this will cause the DO blocks to be excluded
5740      * from the op_next chain (and from having LINKLIST recursively
5741      * applied to them). We fix up the DOs specially later */
5742
5743     is_compiletime = 1;
5744     has_code = 0;
5745     if (expr->op_type == OP_LIST) {
5746         OP *o;
5747         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5748             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5749                 has_code = 1;
5750                 assert(!o->op_next);
5751                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5752                     assert(PL_parser && PL_parser->error_count);
5753                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5754                        the op we were expecting to see, to avoid crashing
5755                        elsewhere.  */
5756                     op_sibling_splice(expr, o, 0,
5757                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5758                 }
5759                 o->op_next = OpSIBLING(o);
5760             }
5761             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5762                 is_compiletime = 0;
5763         }
5764     }
5765     else if (expr->op_type != OP_CONST)
5766         is_compiletime = 0;
5767
5768     LINKLIST(expr);
5769
5770     /* fix up DO blocks; treat each one as a separate little sub;
5771      * also, mark any arrays as LIST/REF */
5772
5773     if (expr->op_type == OP_LIST) {
5774         OP *o;
5775         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5776
5777             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5778                 assert( !(o->op_flags  & OPf_WANT));
5779                 /* push the array rather than its contents. The regex
5780                  * engine will retrieve and join the elements later */
5781                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5782                 continue;
5783             }
5784
5785             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5786                 continue;
5787             o->op_next = NULL; /* undo temporary hack from above */
5788             scalar(o);
5789             LINKLIST(o);
5790             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5791                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5792                 /* skip ENTER */
5793                 assert(leaveop->op_first->op_type == OP_ENTER);
5794                 assert(OpHAS_SIBLING(leaveop->op_first));
5795                 o->op_next = OpSIBLING(leaveop->op_first);
5796                 /* skip leave */
5797                 assert(leaveop->op_flags & OPf_KIDS);
5798                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5799                 leaveop->op_next = NULL; /* stop on last op */
5800                 op_null((OP*)leaveop);
5801             }
5802             else {
5803                 /* skip SCOPE */
5804                 OP *scope = cLISTOPo->op_first;
5805                 assert(scope->op_type == OP_SCOPE);
5806                 assert(scope->op_flags & OPf_KIDS);
5807                 scope->op_next = NULL; /* stop on last op */
5808                 op_null(scope);
5809             }
5810             /* have to peep the DOs individually as we've removed it from
5811              * the op_next chain */
5812             CALL_PEEP(o);
5813             S_prune_chain_head(&(o->op_next));
5814             if (is_compiletime)
5815                 /* runtime finalizes as part of finalizing whole tree */
5816                 finalize_optree(o);
5817         }
5818     }
5819     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5820         assert( !(expr->op_flags  & OPf_WANT));
5821         /* push the array rather than its contents. The regex
5822          * engine will retrieve and join the elements later */
5823         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5824     }
5825
5826     PL_hints |= HINT_BLOCK_SCOPE;
5827     pm = (PMOP*)o;
5828     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5829
5830     if (is_compiletime) {
5831         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5832         regexp_engine const *eng = current_re_engine();
5833
5834         if (is_split) {
5835             /* make engine handle split ' ' specially */
5836             pm->op_pmflags |= PMf_SPLIT;
5837             rx_flags |= RXf_SPLIT;
5838         }
5839
5840         if (!has_code || !eng->op_comp) {
5841             /* compile-time simple constant pattern */
5842
5843             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5844                 /* whoops! we guessed that a qr// had a code block, but we
5845                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5846                  * that isn't required now. Note that we have to be pretty
5847                  * confident that nothing used that CV's pad while the
5848                  * regex was parsed, except maybe op targets for \Q etc.
5849                  * If there were any op targets, though, they should have
5850                  * been stolen by constant folding.
5851                  */
5852 #ifdef DEBUGGING
5853                 SSize_t i = 0;
5854                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5855                 while (++i <= AvFILLp(PL_comppad)) {
5856 #  ifdef USE_PAD_RESET
5857                     /* under USE_PAD_RESET, pad swipe replaces a swiped
5858                      * folded constant with a fresh padtmp */
5859                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5860 #  else
5861                     assert(!PL_curpad[i]);
5862 #  endif
5863                 }
5864 #endif
5865                 /* But we know that one op is using this CV's slab. */
5866                 cv_forget_slab(PL_compcv);
5867                 LEAVE_SCOPE(floor);
5868                 pm->op_pmflags &= ~PMf_HAS_CV;
5869             }
5870
5871             PM_SETRE(pm,
5872                 eng->op_comp
5873                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5874                                         rx_flags, pm->op_pmflags)
5875                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5876                                         rx_flags, pm->op_pmflags)
5877             );
5878             op_free(expr);
5879         }
5880         else {
5881             /* compile-time pattern that includes literal code blocks */
5882             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5883                         rx_flags,
5884                         (pm->op_pmflags |
5885                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5886                     );
5887             PM_SETRE(pm, re);
5888             if (pm->op_pmflags & PMf_HAS_CV) {
5889                 CV *cv;
5890                 /* this QR op (and the anon sub we embed it in) is never
5891                  * actually executed. It's just a placeholder where we can
5892                  * squirrel away expr in op_code_list without the peephole
5893                  * optimiser etc processing it for a second time */
5894                 OP *qr = newPMOP(OP_QR, 0);
5895                 ((PMOP*)qr)->op_code_list = expr;
5896
5897                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5898                 SvREFCNT_inc_simple_void(PL_compcv);
5899                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5900                 ReANY(re)->qr_anoncv = cv;
5901
5902                 /* attach the anon CV to the pad so that
5903                  * pad_fixup_inner_anons() can find it */
5904                 (void)pad_add_anon(cv, o->op_type);
5905                 SvREFCNT_inc_simple_void(cv);
5906             }
5907             else {
5908                 pm->op_code_list = expr;
5909             }
5910         }
5911     }
5912     else {
5913         /* runtime pattern: build chain of regcomp etc ops */
5914         bool reglist;
5915         PADOFFSET cv_targ = 0;
5916
5917         reglist = isreg && expr->op_type == OP_LIST;
5918