cedc5e80b42bf84d14f412c10f40fabd68d0d990
[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) && isIDFIRST_utf8((U8 *)name+1)) ||
659           (name[1] == '_' && len > 2)))
660     {
661         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
662          && isASCII(name[1])
663          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
664             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
665                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
666                               PL_parser->in_my == KEY_state ? "state" : "my"));
667         } else {
668             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
669                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
670         }
671     }
672
673     /* allocate a spare slot and store the name in that slot */
674
675     off = pad_add_name_pvn(name, len,
676                        (is_our ? padadd_OUR :
677                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
678                     PL_parser->in_my_stash,
679                     (is_our
680                         /* $_ is always in main::, even with our */
681                         ? (PL_curstash && !memEQs(name,len,"$_")
682                             ? PL_curstash
683                             : PL_defstash)
684                         : NULL
685                     )
686     );
687     /* anon sub prototypes contains state vars should always be cloned,
688      * otherwise the state var would be shared between anon subs */
689
690     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
691         CvCLONE_on(PL_compcv);
692
693     return off;
694 }
695
696 /*
697 =head1 Optree Manipulation Functions
698
699 =for apidoc alloccopstash
700
701 Available only under threaded builds, this function allocates an entry in
702 C<PL_stashpad> for the stash passed to it.
703
704 =cut
705 */
706
707 #ifdef USE_ITHREADS
708 PADOFFSET
709 Perl_alloccopstash(pTHX_ HV *hv)
710 {
711     PADOFFSET off = 0, o = 1;
712     bool found_slot = FALSE;
713
714     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
715
716     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
717
718     for (; o < PL_stashpadmax; ++o) {
719         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
720         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
721             found_slot = TRUE, off = o;
722     }
723     if (!found_slot) {
724         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
725         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
726         off = PL_stashpadmax;
727         PL_stashpadmax += 10;
728     }
729
730     PL_stashpad[PL_stashpadix = off] = hv;
731     return off;
732 }
733 #endif
734
735 /* free the body of an op without examining its contents.
736  * Always use this rather than FreeOp directly */
737
738 static void
739 S_op_destroy(pTHX_ OP *o)
740 {
741     FreeOp(o);
742 }
743
744 /* Destructor */
745
746 /*
747 =for apidoc Am|void|op_free|OP *o
748
749 Free an op.  Only use this when an op is no longer linked to from any
750 optree.
751
752 =cut
753 */
754
755 void
756 Perl_op_free(pTHX_ OP *o)
757 {
758     dVAR;
759     OPCODE type;
760     SSize_t defer_ix = -1;
761     SSize_t defer_stack_alloc = 0;
762     OP **defer_stack = NULL;
763
764     do {
765
766         /* Though ops may be freed twice, freeing the op after its slab is a
767            big no-no. */
768         assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
769         /* During the forced freeing of ops after compilation failure, kidops
770            may be freed before their parents. */
771         if (!o || o->op_type == OP_FREED)
772             continue;
773
774         type = o->op_type;
775
776         /* an op should only ever acquire op_private flags that we know about.
777          * If this fails, you may need to fix something in regen/op_private.
778          * Don't bother testing if:
779          *   * the op_ppaddr doesn't match the op; someone may have
780          *     overridden the op and be doing strange things with it;
781          *   * we've errored, as op flags are often left in an
782          *     inconsistent state then. Note that an error when
783          *     compiling the main program leaves PL_parser NULL, so
784          *     we can't spot faults in the main code, only
785          *     evaled/required code */
786 #ifdef DEBUGGING
787         if (   o->op_ppaddr == PL_ppaddr[o->op_type]
788             && PL_parser
789             && !PL_parser->error_count)
790         {
791             assert(!(o->op_private & ~PL_op_private_valid[type]));
792         }
793 #endif
794
795         if (o->op_private & OPpREFCOUNTED) {
796             switch (type) {
797             case OP_LEAVESUB:
798             case OP_LEAVESUBLV:
799             case OP_LEAVEEVAL:
800             case OP_LEAVE:
801             case OP_SCOPE:
802             case OP_LEAVEWRITE:
803                 {
804                 PADOFFSET refcnt;
805                 OP_REFCNT_LOCK;
806                 refcnt = OpREFCNT_dec(o);
807                 OP_REFCNT_UNLOCK;
808                 if (refcnt) {
809                     /* Need to find and remove any pattern match ops from the list
810                        we maintain for reset().  */
811                     find_and_forget_pmops(o);
812                     continue;
813                 }
814                 }
815                 break;
816             default:
817                 break;
818             }
819         }
820
821         /* Call the op_free hook if it has been set. Do it now so that it's called
822          * at the right time for refcounted ops, but still before all of the kids
823          * are freed. */
824         CALL_OPFREEHOOK(o);
825
826         if (o->op_flags & OPf_KIDS) {
827             OP *kid, *nextkid;
828             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
829                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
830                 if (!kid || kid->op_type == OP_FREED)
831                     /* During the forced freeing of ops after
832                        compilation failure, kidops may be freed before
833                        their parents. */
834                     continue;
835                 if (!(kid->op_flags & OPf_KIDS))
836                     /* If it has no kids, just free it now */
837                     op_free(kid);
838                 else
839                     DEFER_OP(kid);
840             }
841         }
842         if (type == OP_NULL)
843             type = (OPCODE)o->op_targ;
844
845         if (o->op_slabbed)
846             Slab_to_rw(OpSLAB(o));
847
848         /* COP* is not cleared by op_clear() so that we may track line
849          * numbers etc even after null() */
850         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
851             cop_free((COP*)o);
852         }
853
854         op_clear(o);
855         FreeOp(o);
856 #ifdef DEBUG_LEAKING_SCALARS
857         if (PL_op == o)
858             PL_op = NULL;
859 #endif
860     } while ( (o = POP_DEFERRED_OP()) );
861
862     Safefree(defer_stack);
863 }
864
865 /* S_op_clear_gv(): free a GV attached to an OP */
866
867 STATIC
868 #ifdef USE_ITHREADS
869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
870 #else
871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
872 #endif
873 {
874
875     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
876             || o->op_type == OP_MULTIDEREF)
877 #ifdef USE_ITHREADS
878                 && PL_curpad
879                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
880 #else
881                 ? (GV*)(*svp) : NULL;
882 #endif
883     /* It's possible during global destruction that the GV is freed
884        before the optree. Whilst the SvREFCNT_inc is happy to bump from
885        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
886        will trigger an assertion failure, because the entry to sv_clear
887        checks that the scalar is not already freed.  A check of for
888        !SvIS_FREED(gv) turns out to be invalid, because during global
889        destruction the reference count can be forced down to zero
890        (with SVf_BREAK set).  In which case raising to 1 and then
891        dropping to 0 triggers cleanup before it should happen.  I
892        *think* that this might actually be a general, systematic,
893        weakness of the whole idea of SVf_BREAK, in that code *is*
894        allowed to raise and lower references during global destruction,
895        so any *valid* code that happens to do this during global
896        destruction might well trigger premature cleanup.  */
897     bool still_valid = gv && SvREFCNT(gv);
898
899     if (still_valid)
900         SvREFCNT_inc_simple_void(gv);
901 #ifdef USE_ITHREADS
902     if (*ixp > 0) {
903         pad_swipe(*ixp, TRUE);
904         *ixp = 0;
905     }
906 #else
907     SvREFCNT_dec(*svp);
908     *svp = NULL;
909 #endif
910     if (still_valid) {
911         int try_downgrade = SvREFCNT(gv) == 2;
912         SvREFCNT_dec_NN(gv);
913         if (try_downgrade)
914             gv_try_downgrade(gv);
915     }
916 }
917
918
919 void
920 Perl_op_clear(pTHX_ OP *o)
921 {
922
923     dVAR;
924
925     PERL_ARGS_ASSERT_OP_CLEAR;
926
927     switch (o->op_type) {
928     case OP_NULL:       /* Was holding old type, if any. */
929         /* FALLTHROUGH */
930     case OP_ENTERTRY:
931     case OP_ENTEREVAL:  /* Was holding hints. */
932     case OP_ARGDEFELEM: /* Was holding signature index. */
933         o->op_targ = 0;
934         break;
935     default:
936         if (!(o->op_flags & OPf_REF)
937             || (PL_check[o->op_type] != Perl_ck_ftst))
938             break;
939         /* FALLTHROUGH */
940     case OP_GVSV:
941     case OP_GV:
942     case OP_AELEMFAST:
943 #ifdef USE_ITHREADS
944             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
945 #else
946             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
947 #endif
948         break;
949     case OP_METHOD_REDIR:
950     case OP_METHOD_REDIR_SUPER:
951 #ifdef USE_ITHREADS
952         if (cMETHOPx(o)->op_rclass_targ) {
953             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
954             cMETHOPx(o)->op_rclass_targ = 0;
955         }
956 #else
957         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
958         cMETHOPx(o)->op_rclass_sv = NULL;
959 #endif
960     case OP_METHOD_NAMED:
961     case OP_METHOD_SUPER:
962         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
963         cMETHOPx(o)->op_u.op_meth_sv = NULL;
964 #ifdef USE_ITHREADS
965         if (o->op_targ) {
966             pad_swipe(o->op_targ, 1);
967             o->op_targ = 0;
968         }
969 #endif
970         break;
971     case OP_CONST:
972     case OP_HINTSEVAL:
973         SvREFCNT_dec(cSVOPo->op_sv);
974         cSVOPo->op_sv = NULL;
975 #ifdef USE_ITHREADS
976         /** Bug #15654
977           Even if op_clear does a pad_free for the target of the op,
978           pad_free doesn't actually remove the sv that exists in the pad;
979           instead it lives on. This results in that it could be reused as 
980           a target later on when the pad was reallocated.
981         **/
982         if(o->op_targ) {
983           pad_swipe(o->op_targ,1);
984           o->op_targ = 0;
985         }
986 #endif
987         break;
988     case OP_DUMP:
989     case OP_GOTO:
990     case OP_NEXT:
991     case OP_LAST:
992     case OP_REDO:
993         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
994             break;
995         /* FALLTHROUGH */
996     case OP_TRANS:
997     case OP_TRANSR:
998         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
999             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1000 #ifdef USE_ITHREADS
1001             if (cPADOPo->op_padix > 0) {
1002                 pad_swipe(cPADOPo->op_padix, TRUE);
1003                 cPADOPo->op_padix = 0;
1004             }
1005 #else
1006             SvREFCNT_dec(cSVOPo->op_sv);
1007             cSVOPo->op_sv = NULL;
1008 #endif
1009         }
1010         else {
1011             PerlMemShared_free(cPVOPo->op_pv);
1012             cPVOPo->op_pv = NULL;
1013         }
1014         break;
1015     case OP_SUBST:
1016         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1017         goto clear_pmop;
1018     case OP_PUSHRE:
1019 #ifdef USE_ITHREADS
1020         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1021             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1022         }
1023 #else
1024         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1025 #endif
1026         /* FALLTHROUGH */
1027     case OP_MATCH:
1028     case OP_QR:
1029     clear_pmop:
1030         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1031             op_free(cPMOPo->op_code_list);
1032         cPMOPo->op_code_list = NULL;
1033         forget_pmop(cPMOPo);
1034         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1035         /* we use the same protection as the "SAFE" version of the PM_ macros
1036          * here since sv_clean_all might release some PMOPs
1037          * after PL_regex_padav has been cleared
1038          * and the clearing of PL_regex_padav needs to
1039          * happen before sv_clean_all
1040          */
1041 #ifdef USE_ITHREADS
1042         if(PL_regex_pad) {        /* We could be in destruction */
1043             const IV offset = (cPMOPo)->op_pmoffset;
1044             ReREFCNT_dec(PM_GETRE(cPMOPo));
1045             PL_regex_pad[offset] = &PL_sv_undef;
1046             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1047                            sizeof(offset));
1048         }
1049 #else
1050         ReREFCNT_dec(PM_GETRE(cPMOPo));
1051         PM_SETRE(cPMOPo, NULL);
1052 #endif
1053
1054         break;
1055
1056     case OP_ARGCHECK:
1057         PerlMemShared_free(cUNOP_AUXo->op_aux);
1058         break;
1059
1060     case OP_MULTIDEREF:
1061         {
1062             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1063             UV actions = items->uv;
1064             bool last = 0;
1065             bool is_hash = FALSE;
1066
1067             while (!last) {
1068                 switch (actions & MDEREF_ACTION_MASK) {
1069
1070                 case MDEREF_reload:
1071                     actions = (++items)->uv;
1072                     continue;
1073
1074                 case MDEREF_HV_padhv_helem:
1075                     is_hash = TRUE;
1076                 case MDEREF_AV_padav_aelem:
1077                     pad_free((++items)->pad_offset);
1078                     goto do_elem;
1079
1080                 case MDEREF_HV_gvhv_helem:
1081                     is_hash = TRUE;
1082                 case MDEREF_AV_gvav_aelem:
1083 #ifdef USE_ITHREADS
1084                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1085 #else
1086                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1087 #endif
1088                     goto do_elem;
1089
1090                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1091                     is_hash = TRUE;
1092                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1093 #ifdef USE_ITHREADS
1094                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1095 #else
1096                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1097 #endif
1098                     goto do_vivify_rv2xv_elem;
1099
1100                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1101                     is_hash = TRUE;
1102                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1103                     pad_free((++items)->pad_offset);
1104                     goto do_vivify_rv2xv_elem;
1105
1106                 case MDEREF_HV_pop_rv2hv_helem:
1107                 case MDEREF_HV_vivify_rv2hv_helem:
1108                     is_hash = TRUE;
1109                 do_vivify_rv2xv_elem:
1110                 case MDEREF_AV_pop_rv2av_aelem:
1111                 case MDEREF_AV_vivify_rv2av_aelem:
1112                 do_elem:
1113                     switch (actions & MDEREF_INDEX_MASK) {
1114                     case MDEREF_INDEX_none:
1115                         last = 1;
1116                         break;
1117                     case MDEREF_INDEX_const:
1118                         if (is_hash) {
1119 #ifdef USE_ITHREADS
1120                             /* see RT #15654 */
1121                             pad_swipe((++items)->pad_offset, 1);
1122 #else
1123                             SvREFCNT_dec((++items)->sv);
1124 #endif
1125                         }
1126                         else
1127                             items++;
1128                         break;
1129                     case MDEREF_INDEX_padsv:
1130                         pad_free((++items)->pad_offset);
1131                         break;
1132                     case MDEREF_INDEX_gvsv:
1133 #ifdef USE_ITHREADS
1134                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1135 #else
1136                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1137 #endif
1138                         break;
1139                     }
1140
1141                     if (actions & MDEREF_FLAG_last)
1142                         last = 1;
1143                     is_hash = FALSE;
1144
1145                     break;
1146
1147                 default:
1148                     assert(0);
1149                     last = 1;
1150                     break;
1151
1152                 } /* switch */
1153
1154                 actions >>= MDEREF_SHIFT;
1155             } /* while */
1156
1157             /* start of malloc is at op_aux[-1], where the length is
1158              * stored */
1159             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1160         }
1161         break;
1162     }
1163
1164     if (o->op_targ > 0) {
1165         pad_free(o->op_targ);
1166         o->op_targ = 0;
1167     }
1168 }
1169
1170 STATIC void
1171 S_cop_free(pTHX_ COP* cop)
1172 {
1173     PERL_ARGS_ASSERT_COP_FREE;
1174
1175     CopFILE_free(cop);
1176     if (! specialWARN(cop->cop_warnings))
1177         PerlMemShared_free(cop->cop_warnings);
1178     cophh_free(CopHINTHASH_get(cop));
1179     if (PL_curcop == cop)
1180        PL_curcop = NULL;
1181 }
1182
1183 STATIC void
1184 S_forget_pmop(pTHX_ PMOP *const o
1185               )
1186 {
1187     HV * const pmstash = PmopSTASH(o);
1188
1189     PERL_ARGS_ASSERT_FORGET_PMOP;
1190
1191     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1192         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1193         if (mg) {
1194             PMOP **const array = (PMOP**) mg->mg_ptr;
1195             U32 count = mg->mg_len / sizeof(PMOP**);
1196             U32 i = count;
1197
1198             while (i--) {
1199                 if (array[i] == o) {
1200                     /* Found it. Move the entry at the end to overwrite it.  */
1201                     array[i] = array[--count];
1202                     mg->mg_len = count * sizeof(PMOP**);
1203                     /* Could realloc smaller at this point always, but probably
1204                        not worth it. Probably worth free()ing if we're the
1205                        last.  */
1206                     if(!count) {
1207                         Safefree(mg->mg_ptr);
1208                         mg->mg_ptr = NULL;
1209                     }
1210                     break;
1211                 }
1212             }
1213         }
1214     }
1215     if (PL_curpm == o) 
1216         PL_curpm = NULL;
1217 }
1218
1219 STATIC void
1220 S_find_and_forget_pmops(pTHX_ OP *o)
1221 {
1222     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1223
1224     if (o->op_flags & OPf_KIDS) {
1225         OP *kid = cUNOPo->op_first;
1226         while (kid) {
1227             switch (kid->op_type) {
1228             case OP_SUBST:
1229             case OP_PUSHRE:
1230             case OP_MATCH:
1231             case OP_QR:
1232                 forget_pmop((PMOP*)kid);
1233             }
1234             find_and_forget_pmops(kid);
1235             kid = OpSIBLING(kid);
1236         }
1237     }
1238 }
1239
1240 /*
1241 =for apidoc Am|void|op_null|OP *o
1242
1243 Neutralizes an op when it is no longer needed, but is still linked to from
1244 other ops.
1245
1246 =cut
1247 */
1248
1249 void
1250 Perl_op_null(pTHX_ OP *o)
1251 {
1252     dVAR;
1253
1254     PERL_ARGS_ASSERT_OP_NULL;
1255
1256     if (o->op_type == OP_NULL)
1257         return;
1258     op_clear(o);
1259     o->op_targ = o->op_type;
1260     OpTYPE_set(o, OP_NULL);
1261 }
1262
1263 void
1264 Perl_op_refcnt_lock(pTHX)
1265   PERL_TSA_ACQUIRE(PL_op_mutex)
1266 {
1267 #ifdef USE_ITHREADS
1268     dVAR;
1269 #endif
1270     PERL_UNUSED_CONTEXT;
1271     OP_REFCNT_LOCK;
1272 }
1273
1274 void
1275 Perl_op_refcnt_unlock(pTHX)
1276   PERL_TSA_RELEASE(PL_op_mutex)
1277 {
1278 #ifdef USE_ITHREADS
1279     dVAR;
1280 #endif
1281     PERL_UNUSED_CONTEXT;
1282     OP_REFCNT_UNLOCK;
1283 }
1284
1285
1286 /*
1287 =for apidoc op_sibling_splice
1288
1289 A general function for editing the structure of an existing chain of
1290 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1291 you to delete zero or more sequential nodes, replacing them with zero or
1292 more different nodes.  Performs the necessary op_first/op_last
1293 housekeeping on the parent node and op_sibling manipulation on the
1294 children.  The last deleted node will be marked as as the last node by
1295 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1296
1297 Note that op_next is not manipulated, and nodes are not freed; that is the
1298 responsibility of the caller.  It also won't create a new list op for an
1299 empty list etc; use higher-level functions like op_append_elem() for that.
1300
1301 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1302 the splicing doesn't affect the first or last op in the chain.
1303
1304 C<start> is the node preceding the first node to be spliced.  Node(s)
1305 following it will be deleted, and ops will be inserted after it.  If it is
1306 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1307 beginning.
1308
1309 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1310 If -1 or greater than or equal to the number of remaining kids, all
1311 remaining kids are deleted.
1312
1313 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1314 If C<NULL>, no nodes are inserted.
1315
1316 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1317 deleted.
1318
1319 For example:
1320
1321     action                    before      after         returns
1322     ------                    -----       -----         -------
1323
1324                               P           P
1325     splice(P, A, 2, X-Y-Z)    |           |             B-C
1326                               A-B-C-D     A-X-Y-Z-D
1327
1328                               P           P
1329     splice(P, NULL, 1, X-Y)   |           |             A
1330                               A-B-C-D     X-Y-B-C-D
1331
1332                               P           P
1333     splice(P, NULL, 3, NULL)  |           |             A-B-C
1334                               A-B-C-D     D
1335
1336                               P           P
1337     splice(P, B, 0, X-Y)      |           |             NULL
1338                               A-B-C-D     A-B-X-Y-C-D
1339
1340
1341 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1342 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1343
1344 =cut
1345 */
1346
1347 OP *
1348 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1349 {
1350     OP *first;
1351     OP *rest;
1352     OP *last_del = NULL;
1353     OP *last_ins = NULL;
1354
1355     if (start)
1356         first = OpSIBLING(start);
1357     else if (!parent)
1358         goto no_parent;
1359     else
1360         first = cLISTOPx(parent)->op_first;
1361
1362     assert(del_count >= -1);
1363
1364     if (del_count && first) {
1365         last_del = first;
1366         while (--del_count && OpHAS_SIBLING(last_del))
1367             last_del = OpSIBLING(last_del);
1368         rest = OpSIBLING(last_del);
1369         OpLASTSIB_set(last_del, NULL);
1370     }
1371     else
1372         rest = first;
1373
1374     if (insert) {
1375         last_ins = insert;
1376         while (OpHAS_SIBLING(last_ins))
1377             last_ins = OpSIBLING(last_ins);
1378         OpMAYBESIB_set(last_ins, rest, NULL);
1379     }
1380     else
1381         insert = rest;
1382
1383     if (start) {
1384         OpMAYBESIB_set(start, insert, NULL);
1385     }
1386     else {
1387         if (!parent)
1388             goto no_parent;
1389         cLISTOPx(parent)->op_first = insert;
1390         if (insert)
1391             parent->op_flags |= OPf_KIDS;
1392         else
1393             parent->op_flags &= ~OPf_KIDS;
1394     }
1395
1396     if (!rest) {
1397         /* update op_last etc */
1398         U32 type;
1399         OP *lastop;
1400
1401         if (!parent)
1402             goto no_parent;
1403
1404         /* ought to use OP_CLASS(parent) here, but that can't handle
1405          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1406          * either */
1407         type = parent->op_type;
1408         if (type == OP_CUSTOM) {
1409             dTHX;
1410             type = XopENTRYCUSTOM(parent, xop_class);
1411         }
1412         else {
1413             if (type == OP_NULL)
1414                 type = parent->op_targ;
1415             type = PL_opargs[type] & OA_CLASS_MASK;
1416         }
1417
1418         lastop = last_ins ? last_ins : start ? start : NULL;
1419         if (   type == OA_BINOP
1420             || type == OA_LISTOP
1421             || type == OA_PMOP
1422             || type == OA_LOOP
1423         )
1424             cLISTOPx(parent)->op_last = lastop;
1425
1426         if (lastop)
1427             OpLASTSIB_set(lastop, parent);
1428     }
1429     return last_del ? first : NULL;
1430
1431   no_parent:
1432     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1433 }
1434
1435
1436 #ifdef PERL_OP_PARENT
1437
1438 /*
1439 =for apidoc op_parent
1440
1441 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1442 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1443
1444 =cut
1445 */
1446
1447 OP *
1448 Perl_op_parent(OP *o)
1449 {
1450     PERL_ARGS_ASSERT_OP_PARENT;
1451     while (OpHAS_SIBLING(o))
1452         o = OpSIBLING(o);
1453     return o->op_sibparent;
1454 }
1455
1456 #endif
1457
1458
1459 /* replace the sibling following start with a new UNOP, which becomes
1460  * the parent of the original sibling; e.g.
1461  *
1462  *  op_sibling_newUNOP(P, A, unop-args...)
1463  *
1464  *  P              P
1465  *  |      becomes |
1466  *  A-B-C          A-U-C
1467  *                   |
1468  *                   B
1469  *
1470  * where U is the new UNOP.
1471  *
1472  * parent and start args are the same as for op_sibling_splice();
1473  * type and flags args are as newUNOP().
1474  *
1475  * Returns the new UNOP.
1476  */
1477
1478 STATIC OP *
1479 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1480 {
1481     OP *kid, *newop;
1482
1483     kid = op_sibling_splice(parent, start, 1, NULL);
1484     newop = newUNOP(type, flags, kid);
1485     op_sibling_splice(parent, start, 0, newop);
1486     return newop;
1487 }
1488
1489
1490 /* lowest-level newLOGOP-style function - just allocates and populates
1491  * the struct. Higher-level stuff should be done by S_new_logop() /
1492  * newLOGOP(). This function exists mainly to avoid op_first assignment
1493  * being spread throughout this file.
1494  */
1495
1496 LOGOP *
1497 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1498 {
1499     dVAR;
1500     LOGOP *logop;
1501     OP *kid = first;
1502     NewOp(1101, logop, 1, LOGOP);
1503     OpTYPE_set(logop, type);
1504     logop->op_first = first;
1505     logop->op_other = other;
1506     logop->op_flags = OPf_KIDS;
1507     while (kid && OpHAS_SIBLING(kid))
1508         kid = OpSIBLING(kid);
1509     if (kid)
1510         OpLASTSIB_set(kid, (OP*)logop);
1511     return logop;
1512 }
1513
1514
1515 /* Contextualizers */
1516
1517 /*
1518 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1519
1520 Applies a syntactic context to an op tree representing an expression.
1521 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1522 or C<G_VOID> to specify the context to apply.  The modified op tree
1523 is returned.
1524
1525 =cut
1526 */
1527
1528 OP *
1529 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1530 {
1531     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1532     switch (context) {
1533         case G_SCALAR: return scalar(o);
1534         case G_ARRAY:  return list(o);
1535         case G_VOID:   return scalarvoid(o);
1536         default:
1537             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1538                        (long) context);
1539     }
1540 }
1541
1542 /*
1543
1544 =for apidoc Am|OP*|op_linklist|OP *o
1545 This function is the implementation of the L</LINKLIST> macro.  It should
1546 not be called directly.
1547
1548 =cut
1549 */
1550
1551 OP *
1552 Perl_op_linklist(pTHX_ OP *o)
1553 {
1554     OP *first;
1555
1556     PERL_ARGS_ASSERT_OP_LINKLIST;
1557
1558     if (o->op_next)
1559         return o->op_next;
1560
1561     /* establish postfix order */
1562     first = cUNOPo->op_first;
1563     if (first) {
1564         OP *kid;
1565         o->op_next = LINKLIST(first);
1566         kid = first;
1567         for (;;) {
1568             OP *sibl = OpSIBLING(kid);
1569             if (sibl) {
1570                 kid->op_next = LINKLIST(sibl);
1571                 kid = sibl;
1572             } else {
1573                 kid->op_next = o;
1574                 break;
1575             }
1576         }
1577     }
1578     else
1579         o->op_next = o;
1580
1581     return o->op_next;
1582 }
1583
1584 static OP *
1585 S_scalarkids(pTHX_ OP *o)
1586 {
1587     if (o && o->op_flags & OPf_KIDS) {
1588         OP *kid;
1589         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1590             scalar(kid);
1591     }
1592     return o;
1593 }
1594
1595 STATIC OP *
1596 S_scalarboolean(pTHX_ OP *o)
1597 {
1598     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1599
1600     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1601          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1602         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1603          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1604          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1605         if (ckWARN(WARN_SYNTAX)) {
1606             const line_t oldline = CopLINE(PL_curcop);
1607
1608             if (PL_parser && PL_parser->copline != NOLINE) {
1609                 /* This ensures that warnings are reported at the first line
1610                    of the conditional, not the last.  */
1611                 CopLINE_set(PL_curcop, PL_parser->copline);
1612             }
1613             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1614             CopLINE_set(PL_curcop, oldline);
1615         }
1616     }
1617     return scalar(o);
1618 }
1619
1620 static SV *
1621 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1622 {
1623     assert(o);
1624     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1625            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1626     {
1627         const char funny  = o->op_type == OP_PADAV
1628                          || o->op_type == OP_RV2AV ? '@' : '%';
1629         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1630             GV *gv;
1631             if (cUNOPo->op_first->op_type != OP_GV
1632              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1633                 return NULL;
1634             return varname(gv, funny, 0, NULL, 0, subscript_type);
1635         }
1636         return
1637             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1638     }
1639 }
1640
1641 static SV *
1642 S_op_varname(pTHX_ const OP *o)
1643 {
1644     return S_op_varname_subscript(aTHX_ o, 1);
1645 }
1646
1647 static void
1648 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1649 { /* or not so pretty :-) */
1650     if (o->op_type == OP_CONST) {
1651         *retsv = cSVOPo_sv;
1652         if (SvPOK(*retsv)) {
1653             SV *sv = *retsv;
1654             *retsv = sv_newmortal();
1655             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1656                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1657         }
1658         else if (!SvOK(*retsv))
1659             *retpv = "undef";
1660     }
1661     else *retpv = "...";
1662 }
1663
1664 static void
1665 S_scalar_slice_warning(pTHX_ const OP *o)
1666 {
1667     OP *kid;
1668     const char lbrack =
1669         o->op_type == OP_HSLICE ? '{' : '[';
1670     const char rbrack =
1671         o->op_type == OP_HSLICE ? '}' : ']';
1672     SV *name;
1673     SV *keysv = NULL; /* just to silence compiler warnings */
1674     const char *key = NULL;
1675
1676     if (!(o->op_private & OPpSLICEWARNING))
1677         return;
1678     if (PL_parser && PL_parser->error_count)
1679         /* This warning can be nonsensical when there is a syntax error. */
1680         return;
1681
1682     kid = cLISTOPo->op_first;
1683     kid = OpSIBLING(kid); /* get past pushmark */
1684     /* weed out false positives: any ops that can return lists */
1685     switch (kid->op_type) {
1686     case OP_BACKTICK:
1687     case OP_GLOB:
1688     case OP_READLINE:
1689     case OP_MATCH:
1690     case OP_RV2AV:
1691     case OP_EACH:
1692     case OP_VALUES:
1693     case OP_KEYS:
1694     case OP_SPLIT:
1695     case OP_LIST:
1696     case OP_SORT:
1697     case OP_REVERSE:
1698     case OP_ENTERSUB:
1699     case OP_CALLER:
1700     case OP_LSTAT:
1701     case OP_STAT:
1702     case OP_READDIR:
1703     case OP_SYSTEM:
1704     case OP_TMS:
1705     case OP_LOCALTIME:
1706     case OP_GMTIME:
1707     case OP_ENTEREVAL:
1708         return;
1709     }
1710
1711     /* Don't warn if we have a nulled list either. */
1712     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1713         return;
1714
1715     assert(OpSIBLING(kid));
1716     name = S_op_varname(aTHX_ OpSIBLING(kid));
1717     if (!name) /* XS module fiddling with the op tree */
1718         return;
1719     S_op_pretty(aTHX_ kid, &keysv, &key);
1720     assert(SvPOK(name));
1721     sv_chop(name,SvPVX(name)+1);
1722     if (key)
1723        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1724         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1725                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1726                    "%c%s%c",
1727                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1728                     lbrack, key, rbrack);
1729     else
1730        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1731         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1732                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1733                     SVf"%c%"SVf"%c",
1734                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1735                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1736 }
1737
1738 OP *
1739 Perl_scalar(pTHX_ OP *o)
1740 {
1741     OP *kid;
1742
1743     /* assumes no premature commitment */
1744     if (!o || (PL_parser && PL_parser->error_count)
1745          || (o->op_flags & OPf_WANT)
1746          || o->op_type == OP_RETURN)
1747     {
1748         return o;
1749     }
1750
1751     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1752
1753     switch (o->op_type) {
1754     case OP_REPEAT:
1755         scalar(cBINOPo->op_first);
1756         if (o->op_private & OPpREPEAT_DOLIST) {
1757             kid = cLISTOPx(cUNOPo->op_first)->op_first;
1758             assert(kid->op_type == OP_PUSHMARK);
1759             if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1760                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1761                 o->op_private &=~ OPpREPEAT_DOLIST;
1762             }
1763         }
1764         break;
1765     case OP_OR:
1766     case OP_AND:
1767     case OP_COND_EXPR:
1768         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1769             scalar(kid);
1770         break;
1771         /* FALLTHROUGH */
1772     case OP_SPLIT:
1773     case OP_MATCH:
1774     case OP_QR:
1775     case OP_SUBST:
1776     case OP_NULL:
1777     default:
1778         if (o->op_flags & OPf_KIDS) {
1779             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1780                 scalar(kid);
1781         }
1782         break;
1783     case OP_LEAVE:
1784     case OP_LEAVETRY:
1785         kid = cLISTOPo->op_first;
1786         scalar(kid);
1787         kid = OpSIBLING(kid);
1788     do_kids:
1789         while (kid) {
1790             OP *sib = OpSIBLING(kid);
1791             if (sib && kid->op_type != OP_LEAVEWHEN
1792              && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1793                 || (  sib->op_targ != OP_NEXTSTATE
1794                    && sib->op_targ != OP_DBSTATE  )))
1795                 scalarvoid(kid);
1796             else
1797                 scalar(kid);
1798             kid = sib;
1799         }
1800         PL_curcop = &PL_compiling;
1801         break;
1802     case OP_SCOPE:
1803     case OP_LINESEQ:
1804     case OP_LIST:
1805         kid = cLISTOPo->op_first;
1806         goto do_kids;
1807     case OP_SORT:
1808         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1809         break;
1810     case OP_KVHSLICE:
1811     case OP_KVASLICE:
1812     {
1813         /* Warn about scalar context */
1814         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1815         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1816         SV *name;
1817         SV *keysv;
1818         const char *key = NULL;
1819
1820         /* This warning can be nonsensical when there is a syntax error. */
1821         if (PL_parser && PL_parser->error_count)
1822             break;
1823
1824         if (!ckWARN(WARN_SYNTAX)) break;
1825
1826         kid = cLISTOPo->op_first;
1827         kid = OpSIBLING(kid); /* get past pushmark */
1828         assert(OpSIBLING(kid));
1829         name = S_op_varname(aTHX_ OpSIBLING(kid));
1830         if (!name) /* XS module fiddling with the op tree */
1831             break;
1832         S_op_pretty(aTHX_ kid, &keysv, &key);
1833         assert(SvPOK(name));
1834         sv_chop(name,SvPVX(name)+1);
1835         if (key)
1836   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1837             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1838                        "%%%"SVf"%c%s%c in scalar context better written "
1839                        "as $%"SVf"%c%s%c",
1840                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1841                         lbrack, key, rbrack);
1842         else
1843   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1844             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1845                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1846                        "written as $%"SVf"%c%"SVf"%c",
1847                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1848                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1849     }
1850     }
1851     return o;
1852 }
1853
1854 OP *
1855 Perl_scalarvoid(pTHX_ OP *arg)
1856 {
1857     dVAR;
1858     OP *kid;
1859     SV* sv;
1860     U8 want;
1861     SSize_t defer_stack_alloc = 0;
1862     SSize_t defer_ix = -1;
1863     OP **defer_stack = NULL;
1864     OP *o = arg;
1865
1866     PERL_ARGS_ASSERT_SCALARVOID;
1867
1868     do {
1869         SV *useless_sv = NULL;
1870         const char* useless = NULL;
1871
1872         if (o->op_type == OP_NEXTSTATE
1873             || o->op_type == OP_DBSTATE
1874             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1875                                           || o->op_targ == OP_DBSTATE)))
1876             PL_curcop = (COP*)o;                /* for warning below */
1877
1878         /* assumes no premature commitment */
1879         want = o->op_flags & OPf_WANT;
1880         if ((want && want != OPf_WANT_SCALAR)
1881             || (PL_parser && PL_parser->error_count)
1882             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1883         {
1884             continue;
1885         }
1886
1887         if ((o->op_private & OPpTARGET_MY)
1888             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1889         {
1890             /* newASSIGNOP has already applied scalar context, which we
1891                leave, as if this op is inside SASSIGN.  */
1892             continue;
1893         }
1894
1895         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1896
1897         switch (o->op_type) {
1898         default:
1899             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1900                 break;
1901             /* FALLTHROUGH */
1902         case OP_REPEAT:
1903             if (o->op_flags & OPf_STACKED)
1904                 break;
1905             if (o->op_type == OP_REPEAT)
1906                 scalar(cBINOPo->op_first);
1907             goto func_ops;
1908         case OP_SUBSTR:
1909             if (o->op_private == 4)
1910                 break;
1911             /* FALLTHROUGH */
1912         case OP_WANTARRAY:
1913         case OP_GV:
1914         case OP_SMARTMATCH:
1915         case OP_AV2ARYLEN:
1916         case OP_REF:
1917         case OP_REFGEN:
1918         case OP_SREFGEN:
1919         case OP_DEFINED:
1920         case OP_HEX:
1921         case OP_OCT:
1922         case OP_LENGTH:
1923         case OP_VEC:
1924         case OP_INDEX:
1925         case OP_RINDEX:
1926         case OP_SPRINTF:
1927         case OP_KVASLICE:
1928         case OP_KVHSLICE:
1929         case OP_UNPACK:
1930         case OP_PACK:
1931         case OP_JOIN:
1932         case OP_LSLICE:
1933         case OP_ANONLIST:
1934         case OP_ANONHASH:
1935         case OP_SORT:
1936         case OP_REVERSE:
1937         case OP_RANGE:
1938         case OP_FLIP:
1939         case OP_FLOP:
1940         case OP_CALLER:
1941         case OP_FILENO:
1942         case OP_EOF:
1943         case OP_TELL:
1944         case OP_GETSOCKNAME:
1945         case OP_GETPEERNAME:
1946         case OP_READLINK:
1947         case OP_TELLDIR:
1948         case OP_GETPPID:
1949         case OP_GETPGRP:
1950         case OP_GETPRIORITY:
1951         case OP_TIME:
1952         case OP_TMS:
1953         case OP_LOCALTIME:
1954         case OP_GMTIME:
1955         case OP_GHBYNAME:
1956         case OP_GHBYADDR:
1957         case OP_GHOSTENT:
1958         case OP_GNBYNAME:
1959         case OP_GNBYADDR:
1960         case OP_GNETENT:
1961         case OP_GPBYNAME:
1962         case OP_GPBYNUMBER:
1963         case OP_GPROTOENT:
1964         case OP_GSBYNAME:
1965         case OP_GSBYPORT:
1966         case OP_GSERVENT:
1967         case OP_GPWNAM:
1968         case OP_GPWUID:
1969         case OP_GGRNAM:
1970         case OP_GGRGID:
1971         case OP_GETLOGIN:
1972         case OP_PROTOTYPE:
1973         case OP_RUNCV:
1974         func_ops:
1975             useless = OP_DESC(o);
1976             break;
1977
1978         case OP_GVSV:
1979         case OP_PADSV:
1980         case OP_PADAV:
1981         case OP_PADHV:
1982         case OP_PADANY:
1983         case OP_AELEM:
1984         case OP_AELEMFAST:
1985         case OP_AELEMFAST_LEX:
1986         case OP_ASLICE:
1987         case OP_HELEM:
1988         case OP_HSLICE:
1989             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1990                 /* Otherwise it's "Useless use of grep iterator" */
1991                 useless = OP_DESC(o);
1992             break;
1993
1994         case OP_SPLIT:
1995             kid = cLISTOPo->op_first;
1996             if (kid && kid->op_type == OP_PUSHRE
1997                 && !kid->op_targ
1998                 && !(o->op_flags & OPf_STACKED)
1999 #ifdef USE_ITHREADS
2000                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2001 #else
2002                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2003 #endif
2004                 )
2005                 useless = OP_DESC(o);
2006             break;
2007
2008         case OP_NOT:
2009             kid = cUNOPo->op_first;
2010             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2011                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2012                 goto func_ops;
2013             }
2014             useless = "negative pattern binding (!~)";
2015             break;
2016
2017         case OP_SUBST:
2018             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2019                 useless = "non-destructive substitution (s///r)";
2020             break;
2021
2022         case OP_TRANSR:
2023             useless = "non-destructive transliteration (tr///r)";
2024             break;
2025
2026         case OP_RV2GV:
2027         case OP_RV2SV:
2028         case OP_RV2AV:
2029         case OP_RV2HV:
2030             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2031                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2032                 useless = "a variable";
2033             break;
2034
2035         case OP_CONST:
2036             sv = cSVOPo_sv;
2037             if (cSVOPo->op_private & OPpCONST_STRICT)
2038                 no_bareword_allowed(o);
2039             else {
2040                 if (ckWARN(WARN_VOID)) {
2041                     NV nv;
2042                     /* don't warn on optimised away booleans, eg
2043                      * use constant Foo, 5; Foo || print; */
2044                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2045                         useless = NULL;
2046                     /* the constants 0 and 1 are permitted as they are
2047                        conventionally used as dummies in constructs like
2048                        1 while some_condition_with_side_effects;  */
2049                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2050                         useless = NULL;
2051                     else if (SvPOK(sv)) {
2052                         SV * const dsv = newSVpvs("");
2053                         useless_sv
2054                             = Perl_newSVpvf(aTHX_
2055                                             "a constant (%s)",
2056                                             pv_pretty(dsv, SvPVX_const(sv),
2057                                                       SvCUR(sv), 32, NULL, NULL,
2058                                                       PERL_PV_PRETTY_DUMP
2059                                                       | PERL_PV_ESCAPE_NOCLEAR
2060                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2061                         SvREFCNT_dec_NN(dsv);
2062                     }
2063                     else if (SvOK(sv)) {
2064                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2065                     }
2066                     else
2067                         useless = "a constant (undef)";
2068                 }
2069             }
2070             op_null(o);         /* don't execute or even remember it */
2071             break;
2072
2073         case OP_POSTINC:
2074             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2075             break;
2076
2077         case OP_POSTDEC:
2078             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2079             break;
2080
2081         case OP_I_POSTINC:
2082             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2083             break;
2084
2085         case OP_I_POSTDEC:
2086             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2087             break;
2088
2089         case OP_SASSIGN: {
2090             OP *rv2gv;
2091             UNOP *refgen, *rv2cv;
2092             LISTOP *exlist;
2093
2094             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2095                 break;
2096
2097             rv2gv = ((BINOP *)o)->op_last;
2098             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2099                 break;
2100
2101             refgen = (UNOP *)((BINOP *)o)->op_first;
2102
2103             if (!refgen || (refgen->op_type != OP_REFGEN
2104                             && refgen->op_type != OP_SREFGEN))
2105                 break;
2106
2107             exlist = (LISTOP *)refgen->op_first;
2108             if (!exlist || exlist->op_type != OP_NULL
2109                 || exlist->op_targ != OP_LIST)
2110                 break;
2111
2112             if (exlist->op_first->op_type != OP_PUSHMARK
2113                 && exlist->op_first != exlist->op_last)
2114                 break;
2115
2116             rv2cv = (UNOP*)exlist->op_last;
2117
2118             if (rv2cv->op_type != OP_RV2CV)
2119                 break;
2120
2121             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2122             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2123             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2124
2125             o->op_private |= OPpASSIGN_CV_TO_GV;
2126             rv2gv->op_private |= OPpDONT_INIT_GV;
2127             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2128
2129             break;
2130         }
2131
2132         case OP_AASSIGN: {
2133             inplace_aassign(o);
2134             break;
2135         }
2136
2137         case OP_OR:
2138         case OP_AND:
2139             kid = cLOGOPo->op_first;
2140             if (kid->op_type == OP_NOT
2141                 && (kid->op_flags & OPf_KIDS)) {
2142                 if (o->op_type == OP_AND) {
2143                     OpTYPE_set(o, OP_OR);
2144                 } else {
2145                     OpTYPE_set(o, OP_AND);
2146                 }
2147                 op_null(kid);
2148             }
2149             /* FALLTHROUGH */
2150
2151         case OP_DOR:
2152         case OP_COND_EXPR:
2153         case OP_ENTERGIVEN:
2154         case OP_ENTERWHEN:
2155             for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2156                 if (!(kid->op_flags & OPf_KIDS))
2157                     scalarvoid(kid);
2158                 else
2159                     DEFER_OP(kid);
2160         break;
2161
2162         case OP_NULL:
2163             if (o->op_flags & OPf_STACKED)
2164                 break;
2165             /* FALLTHROUGH */
2166         case OP_NEXTSTATE:
2167         case OP_DBSTATE:
2168         case OP_ENTERTRY:
2169         case OP_ENTER:
2170             if (!(o->op_flags & OPf_KIDS))
2171                 break;
2172             /* FALLTHROUGH */
2173         case OP_SCOPE:
2174         case OP_LEAVE:
2175         case OP_LEAVETRY:
2176         case OP_LEAVELOOP:
2177         case OP_LINESEQ:
2178         case OP_LEAVEGIVEN:
2179         case OP_LEAVEWHEN:
2180         kids:
2181             for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2182                 if (!(kid->op_flags & OPf_KIDS))
2183                     scalarvoid(kid);
2184                 else
2185                     DEFER_OP(kid);
2186             break;
2187         case OP_LIST:
2188             /* If the first kid after pushmark is something that the padrange
2189                optimisation would reject, then null the list and the pushmark.
2190             */
2191             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2192                 && (  !(kid = OpSIBLING(kid))
2193                       || (  kid->op_type != OP_PADSV
2194                             && kid->op_type != OP_PADAV
2195                             && kid->op_type != OP_PADHV)
2196                       || kid->op_private & ~OPpLVAL_INTRO
2197                       || !(kid = OpSIBLING(kid))
2198                       || (  kid->op_type != OP_PADSV
2199                             && kid->op_type != OP_PADAV
2200                             && kid->op_type != OP_PADHV)
2201                       || kid->op_private & ~OPpLVAL_INTRO)
2202             ) {
2203                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2204                 op_null(o); /* NULL the list */
2205             }
2206             goto kids;
2207         case OP_ENTEREVAL:
2208             scalarkids(o);
2209             break;
2210         case OP_SCALAR:
2211             scalar(o);
2212             break;
2213         }
2214
2215         if (useless_sv) {
2216             /* mortalise it, in case warnings are fatal.  */
2217             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218                            "Useless use of %"SVf" in void context",
2219                            SVfARG(sv_2mortal(useless_sv)));
2220         }
2221         else if (useless) {
2222             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2223                            "Useless use of %s in void context",
2224                            useless);
2225         }
2226     } while ( (o = POP_DEFERRED_OP()) );
2227
2228     Safefree(defer_stack);
2229
2230     return arg;
2231 }
2232
2233 static OP *
2234 S_listkids(pTHX_ OP *o)
2235 {
2236     if (o && o->op_flags & OPf_KIDS) {
2237         OP *kid;
2238         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2239             list(kid);
2240     }
2241     return o;
2242 }
2243
2244 OP *
2245 Perl_list(pTHX_ OP *o)
2246 {
2247     OP *kid;
2248
2249     /* assumes no premature commitment */
2250     if (!o || (o->op_flags & OPf_WANT)
2251          || (PL_parser && PL_parser->error_count)
2252          || o->op_type == OP_RETURN)
2253     {
2254         return o;
2255     }
2256
2257     if ((o->op_private & OPpTARGET_MY)
2258         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2259     {
2260         return o;                               /* As if inside SASSIGN */
2261     }
2262
2263     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2264
2265     switch (o->op_type) {
2266     case OP_FLOP:
2267         list(cBINOPo->op_first);
2268         break;
2269     case OP_REPEAT:
2270         if (o->op_private & OPpREPEAT_DOLIST
2271          && !(o->op_flags & OPf_STACKED))
2272         {
2273             list(cBINOPo->op_first);
2274             kid = cBINOPo->op_last;
2275             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2276              && SvIVX(kSVOP_sv) == 1)
2277             {
2278                 op_null(o); /* repeat */
2279                 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2280                 /* const (rhs): */
2281                 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2282             }
2283         }
2284         break;
2285     case OP_OR:
2286     case OP_AND:
2287     case OP_COND_EXPR:
2288         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2289             list(kid);
2290         break;
2291     default:
2292     case OP_MATCH:
2293     case OP_QR:
2294     case OP_SUBST:
2295     case OP_NULL:
2296         if (!(o->op_flags & OPf_KIDS))
2297             break;
2298         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2299             list(cBINOPo->op_first);
2300             return gen_constant_list(o);
2301         }
2302         listkids(o);
2303         break;
2304     case OP_LIST:
2305         listkids(o);
2306         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2307             op_null(cUNOPo->op_first); /* NULL the pushmark */
2308             op_null(o); /* NULL the list */
2309         }
2310         break;
2311     case OP_LEAVE:
2312     case OP_LEAVETRY:
2313         kid = cLISTOPo->op_first;
2314         list(kid);
2315         kid = OpSIBLING(kid);
2316     do_kids:
2317         while (kid) {
2318             OP *sib = OpSIBLING(kid);
2319             if (sib && kid->op_type != OP_LEAVEWHEN)
2320                 scalarvoid(kid);
2321             else
2322                 list(kid);
2323             kid = sib;
2324         }
2325         PL_curcop = &PL_compiling;
2326         break;
2327     case OP_SCOPE:
2328     case OP_LINESEQ:
2329         kid = cLISTOPo->op_first;
2330         goto do_kids;
2331     }
2332     return o;
2333 }
2334
2335 static OP *
2336 S_scalarseq(pTHX_ OP *o)
2337 {
2338     if (o) {
2339         const OPCODE type = o->op_type;
2340
2341         if (type == OP_LINESEQ || type == OP_SCOPE ||
2342             type == OP_LEAVE || type == OP_LEAVETRY)
2343         {
2344             OP *kid, *sib;
2345             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2346                 if ((sib = OpSIBLING(kid))
2347                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2348                     || (  sib->op_targ != OP_NEXTSTATE
2349                        && sib->op_targ != OP_DBSTATE  )))
2350                 {
2351                     scalarvoid(kid);
2352                 }
2353             }
2354             PL_curcop = &PL_compiling;
2355         }
2356         o->op_flags &= ~OPf_PARENS;
2357         if (PL_hints & HINT_BLOCK_SCOPE)
2358             o->op_flags |= OPf_PARENS;
2359     }
2360     else
2361         o = newOP(OP_STUB, 0);
2362     return o;
2363 }
2364
2365 STATIC OP *
2366 S_modkids(pTHX_ OP *o, I32 type)
2367 {
2368     if (o && o->op_flags & OPf_KIDS) {
2369         OP *kid;
2370         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2371             op_lvalue(kid, type);
2372     }
2373     return o;
2374 }
2375
2376
2377 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2378  * const fields. Also, convert CONST keys to HEK-in-SVs.
2379  * rop is the op that retrieves the hash;
2380  * key_op is the first key
2381  */
2382
2383 STATIC void
2384 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2385 {
2386     PADNAME *lexname;
2387     GV **fields;
2388     bool check_fields;
2389
2390     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2391     if (rop) {
2392         if (rop->op_first->op_type == OP_PADSV)
2393             /* @$hash{qw(keys here)} */
2394             rop = (UNOP*)rop->op_first;
2395         else {
2396             /* @{$hash}{qw(keys here)} */
2397             if (rop->op_first->op_type == OP_SCOPE
2398                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2399                 {
2400                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2401                 }
2402             else
2403                 rop = NULL;
2404         }
2405     }
2406
2407     lexname = NULL; /* just to silence compiler warnings */
2408     fields  = NULL; /* just to silence compiler warnings */
2409
2410     check_fields =
2411             rop
2412          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2413              SvPAD_TYPED(lexname))
2414          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2415          && isGV(*fields) && GvHV(*fields);
2416
2417     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2418         SV **svp, *sv;
2419         if (key_op->op_type != OP_CONST)
2420             continue;
2421         svp = cSVOPx_svp(key_op);
2422
2423         /* make sure it's not a bareword under strict subs */
2424         if (key_op->op_private & OPpCONST_BARE &&
2425             key_op->op_private & OPpCONST_STRICT)
2426         {
2427             no_bareword_allowed((OP*)key_op);
2428         }
2429
2430         /* Make the CONST have a shared SV */
2431         if (   !SvIsCOW_shared_hash(sv = *svp)
2432             && SvTYPE(sv) < SVt_PVMG
2433             && SvOK(sv)
2434             && !SvROK(sv))
2435         {
2436             SSize_t keylen;
2437             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2438             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2439             SvREFCNT_dec_NN(sv);
2440             *svp = nsv;
2441         }
2442
2443         if (   check_fields
2444             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2445         {
2446             Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2447                         "in variable %"PNf" of type %"HEKf,
2448                         SVfARG(*svp), PNfARG(lexname),
2449                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2450         }
2451     }
2452 }
2453
2454
2455 /*
2456 =for apidoc finalize_optree
2457
2458 This function finalizes the optree.  Should be called directly after
2459 the complete optree is built.  It does some additional
2460 checking which can't be done in the normal C<ck_>xxx functions and makes
2461 the tree thread-safe.
2462
2463 =cut
2464 */
2465 void
2466 Perl_finalize_optree(pTHX_ OP* o)
2467 {
2468     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2469
2470     ENTER;
2471     SAVEVPTR(PL_curcop);
2472
2473     finalize_op(o);
2474
2475     LEAVE;
2476 }
2477
2478 #ifdef USE_ITHREADS
2479 /* Relocate sv to the pad for thread safety.
2480  * Despite being a "constant", the SV is written to,
2481  * for reference counts, sv_upgrade() etc. */
2482 PERL_STATIC_INLINE void
2483 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2484 {
2485     PADOFFSET ix;
2486     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2487     if (!*svp) return;
2488     ix = pad_alloc(OP_CONST, SVf_READONLY);
2489     SvREFCNT_dec(PAD_SVl(ix));
2490     PAD_SETSV(ix, *svp);
2491     /* XXX I don't know how this isn't readonly already. */
2492     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2493     *svp = NULL;
2494     *targp = ix;
2495 }
2496 #endif
2497
2498
2499 STATIC void
2500 S_finalize_op(pTHX_ OP* o)
2501 {
2502     PERL_ARGS_ASSERT_FINALIZE_OP;
2503
2504
2505     switch (o->op_type) {
2506     case OP_NEXTSTATE:
2507     case OP_DBSTATE:
2508         PL_curcop = ((COP*)o);          /* for warnings */
2509         break;
2510     case OP_EXEC:
2511         if (OpHAS_SIBLING(o)) {
2512             OP *sib = OpSIBLING(o);
2513             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2514                 && ckWARN(WARN_EXEC)
2515                 && OpHAS_SIBLING(sib))
2516             {
2517                     const OPCODE type = OpSIBLING(sib)->op_type;
2518                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2519                         const line_t oldline = CopLINE(PL_curcop);
2520                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2521                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2522                             "Statement unlikely to be reached");
2523                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2524                             "\t(Maybe you meant system() when you said exec()?)\n");
2525                         CopLINE_set(PL_curcop, oldline);
2526                     }
2527             }
2528         }
2529         break;
2530
2531     case OP_GV:
2532         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2533             GV * const gv = cGVOPo_gv;
2534             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2535                 /* XXX could check prototype here instead of just carping */
2536                 SV * const sv = sv_newmortal();
2537                 gv_efullname3(sv, gv, NULL);
2538                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2539                     "%"SVf"() called too early to check prototype",
2540                     SVfARG(sv));
2541             }
2542         }
2543         break;
2544
2545     case OP_CONST:
2546         if (cSVOPo->op_private & OPpCONST_STRICT)
2547             no_bareword_allowed(o);
2548         /* FALLTHROUGH */
2549 #ifdef USE_ITHREADS
2550     case OP_HINTSEVAL:
2551         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2552 #endif
2553         break;
2554
2555 #ifdef USE_ITHREADS
2556     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2557     case OP_METHOD_NAMED:
2558     case OP_METHOD_SUPER:
2559     case OP_METHOD_REDIR:
2560     case OP_METHOD_REDIR_SUPER:
2561         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2562         break;
2563 #endif
2564
2565     case OP_HELEM: {
2566         UNOP *rop;
2567         SVOP *key_op;
2568         OP *kid;
2569
2570         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2571             break;
2572
2573         rop = (UNOP*)((BINOP*)o)->op_first;
2574
2575         goto check_keys;
2576
2577     case OP_HSLICE:
2578         S_scalar_slice_warning(aTHX_ o);
2579         /* FALLTHROUGH */
2580
2581     case OP_KVHSLICE:
2582         kid = OpSIBLING(cLISTOPo->op_first);
2583         if (/* I bet there's always a pushmark... */
2584             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2585             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2586         {
2587             break;
2588         }
2589
2590         key_op = (SVOP*)(kid->op_type == OP_CONST
2591                                 ? kid
2592                                 : OpSIBLING(kLISTOP->op_first));
2593
2594         rop = (UNOP*)((LISTOP*)o)->op_last;
2595
2596       check_keys:       
2597         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2598             rop = NULL;
2599         S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2600         break;
2601     }
2602     case OP_ASLICE:
2603         S_scalar_slice_warning(aTHX_ o);
2604         break;
2605
2606     case OP_SUBST: {
2607         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2608             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2609         break;
2610     }
2611     default:
2612         break;
2613     }
2614
2615     if (o->op_flags & OPf_KIDS) {
2616         OP *kid;
2617
2618 #ifdef DEBUGGING
2619         /* check that op_last points to the last sibling, and that
2620          * the last op_sibling/op_sibparent field points back to the
2621          * parent, and that the only ops with KIDS are those which are
2622          * entitled to them */
2623         U32 type = o->op_type;
2624         U32 family;
2625         bool has_last;
2626
2627         if (type == OP_NULL) {
2628             type = o->op_targ;
2629             /* ck_glob creates a null UNOP with ex-type GLOB
2630              * (which is a list op. So pretend it wasn't a listop */
2631             if (type == OP_GLOB)
2632                 type = OP_NULL;
2633         }
2634         family = PL_opargs[type] & OA_CLASS_MASK;
2635
2636         has_last = (   family == OA_BINOP
2637                     || family == OA_LISTOP
2638                     || family == OA_PMOP
2639                     || family == OA_LOOP
2640                    );
2641         assert(  has_last /* has op_first and op_last, or ...
2642               ... has (or may have) op_first: */
2643               || family == OA_UNOP
2644               || family == OA_UNOP_AUX
2645               || family == OA_LOGOP
2646               || family == OA_BASEOP_OR_UNOP
2647               || family == OA_FILESTATOP
2648               || family == OA_LOOPEXOP
2649               || family == OA_METHOP
2650               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2651               || type == OP_SASSIGN
2652               || type == OP_CUSTOM
2653               || type == OP_NULL /* new_logop does this */
2654               );
2655
2656         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2657 #  ifdef PERL_OP_PARENT
2658             if (!OpHAS_SIBLING(kid)) {
2659                 if (has_last)
2660                     assert(kid == cLISTOPo->op_last);
2661                 assert(kid->op_sibparent == o);
2662             }
2663 #  else
2664             if (has_last && !OpHAS_SIBLING(kid))
2665                 assert(kid == cLISTOPo->op_last);
2666 #  endif
2667         }
2668 #endif
2669
2670         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2671             finalize_op(kid);
2672     }
2673 }
2674
2675 /*
2676 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2677
2678 Propagate lvalue ("modifiable") context to an op and its children.
2679 C<type> represents the context type, roughly based on the type of op that
2680 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2681 because it has no op type of its own (it is signalled by a flag on
2682 the lvalue op).
2683
2684 This function detects things that can't be modified, such as C<$x+1>, and
2685 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2686 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2687
2688 It also flags things that need to behave specially in an lvalue context,
2689 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2690
2691 =cut
2692 */
2693
2694 static void
2695 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2696 {
2697     CV *cv = PL_compcv;
2698     PadnameLVALUE_on(pn);
2699     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2700         cv = CvOUTSIDE(cv);
2701         /* RT #127786: cv can be NULL due to an eval within the DB package
2702          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2703          * unless they contain an eval, but calling eval within DB
2704          * pretends the eval was done in the caller's scope.
2705          */
2706         if (!cv)
2707             break;
2708         assert(CvPADLIST(cv));
2709         pn =
2710            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2711         assert(PadnameLEN(pn));
2712         PadnameLVALUE_on(pn);
2713     }
2714 }
2715
2716 static bool
2717 S_vivifies(const OPCODE type)
2718 {
2719     switch(type) {
2720     case OP_RV2AV:     case   OP_ASLICE:
2721     case OP_RV2HV:     case OP_KVASLICE:
2722     case OP_RV2SV:     case   OP_HSLICE:
2723     case OP_AELEMFAST: case OP_KVHSLICE:
2724     case OP_HELEM:
2725     case OP_AELEM:
2726         return 1;
2727     }
2728     return 0;
2729 }
2730
2731 static void
2732 S_lvref(pTHX_ OP *o, I32 type)
2733 {
2734     dVAR;
2735     OP *kid;
2736     switch (o->op_type) {
2737     case OP_COND_EXPR:
2738         for (kid = OpSIBLING(cUNOPo->op_first); kid;
2739              kid = OpSIBLING(kid))
2740             S_lvref(aTHX_ kid, type);
2741         /* FALLTHROUGH */
2742     case OP_PUSHMARK:
2743         return;
2744     case OP_RV2AV:
2745         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2746         o->op_flags |= OPf_STACKED;
2747         if (o->op_flags & OPf_PARENS) {
2748             if (o->op_private & OPpLVAL_INTRO) {
2749                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2750                       "localized parenthesized array in list assignment"));
2751                 return;
2752             }
2753           slurpy:
2754             OpTYPE_set(o, OP_LVAVREF);
2755             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2756             o->op_flags |= OPf_MOD|OPf_REF;
2757             return;
2758         }
2759         o->op_private |= OPpLVREF_AV;
2760         goto checkgv;
2761     case OP_RV2CV:
2762         kid = cUNOPo->op_first;
2763         if (kid->op_type == OP_NULL)
2764             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2765                 ->op_first;
2766         o->op_private = OPpLVREF_CV;
2767         if (kid->op_type == OP_GV)
2768             o->op_flags |= OPf_STACKED;
2769         else if (kid->op_type == OP_PADCV) {
2770             o->op_targ = kid->op_targ;
2771             kid->op_targ = 0;
2772             op_free(cUNOPo->op_first);
2773             cUNOPo->op_first = NULL;
2774             o->op_flags &=~ OPf_KIDS;
2775         }
2776         else goto badref;
2777         break;
2778     case OP_RV2HV:
2779         if (o->op_flags & OPf_PARENS) {
2780           parenhash:
2781             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2782                                  "parenthesized hash in list assignment"));
2783                 return;
2784         }
2785         o->op_private |= OPpLVREF_HV;
2786         /* FALLTHROUGH */
2787     case OP_RV2SV:
2788       checkgv:
2789         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2790         o->op_flags |= OPf_STACKED;
2791         break;
2792     case OP_PADHV:
2793         if (o->op_flags & OPf_PARENS) goto parenhash;
2794         o->op_private |= OPpLVREF_HV;
2795         /* FALLTHROUGH */
2796     case OP_PADSV:
2797         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2798         break;
2799     case OP_PADAV:
2800         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2801         if (o->op_flags & OPf_PARENS) goto slurpy;
2802         o->op_private |= OPpLVREF_AV;
2803         break;
2804     case OP_AELEM:
2805     case OP_HELEM:
2806         o->op_private |= OPpLVREF_ELEM;
2807         o->op_flags   |= OPf_STACKED;
2808         break;
2809     case OP_ASLICE:
2810     case OP_HSLICE:
2811         OpTYPE_set(o, OP_LVREFSLICE);
2812         o->op_private &= OPpLVAL_INTRO;
2813         return;
2814     case OP_NULL:
2815         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2816             goto badref;
2817         else if (!(o->op_flags & OPf_KIDS))
2818             return;
2819         if (o->op_targ != OP_LIST) {
2820             S_lvref(aTHX_ cBINOPo->op_first, type);
2821             return;
2822         }
2823         /* FALLTHROUGH */
2824     case OP_LIST:
2825         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2826             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2827             S_lvref(aTHX_ kid, type);
2828         }
2829         return;
2830     case OP_STUB:
2831         if (o->op_flags & OPf_PARENS)
2832             return;
2833         /* FALLTHROUGH */
2834     default:
2835       badref:
2836         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2837         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2838                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2839                       ? "do block"
2840                       : OP_DESC(o),
2841                      PL_op_desc[type]));
2842         return;
2843     }
2844     OpTYPE_set(o, OP_LVREF);
2845     o->op_private &=
2846         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2847     if (type == OP_ENTERLOOP)
2848         o->op_private |= OPpLVREF_ITER;
2849 }
2850
2851 PERL_STATIC_INLINE bool
2852 S_potential_mod_type(I32 type)
2853 {
2854     /* Types that only potentially result in modification.  */
2855     return type == OP_GREPSTART || type == OP_ENTERSUB
2856         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
2857 }
2858
2859 OP *
2860 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2861 {
2862     dVAR;
2863     OP *kid;
2864     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2865     int localize = -1;
2866
2867     if (!o || (PL_parser && PL_parser->error_count))
2868         return o;
2869
2870     if ((o->op_private & OPpTARGET_MY)
2871         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2872     {
2873         return o;
2874     }
2875
2876     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2877
2878     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2879
2880     switch (o->op_type) {
2881     case OP_UNDEF:
2882         PL_modcount++;
2883         return o;
2884     case OP_STUB:
2885         if ((o->op_flags & OPf_PARENS))
2886             break;
2887         goto nomod;
2888     case OP_ENTERSUB:
2889         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2890             !(o->op_flags & OPf_STACKED)) {
2891             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
2892             assert(cUNOPo->op_first->op_type == OP_NULL);
2893             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2894             break;
2895         }
2896         else {                          /* lvalue subroutine call */
2897             o->op_private |= OPpLVAL_INTRO;
2898             PL_modcount = RETURN_UNLIMITED_NUMBER;
2899             if (S_potential_mod_type(type)) {
2900                 o->op_private |= OPpENTERSUB_INARGS;
2901                 break;
2902             }
2903             else {                      /* Compile-time error message: */
2904                 OP *kid = cUNOPo->op_first;
2905                 CV *cv;
2906                 GV *gv;
2907                 SV *namesv;
2908
2909                 if (kid->op_type != OP_PUSHMARK) {
2910                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2911                         Perl_croak(aTHX_
2912                                 "panic: unexpected lvalue entersub "
2913                                 "args: type/targ %ld:%"UVuf,
2914                                 (long)kid->op_type, (UV)kid->op_targ);
2915                     kid = kLISTOP->op_first;
2916                 }
2917                 while (OpHAS_SIBLING(kid))
2918                     kid = OpSIBLING(kid);
2919                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2920                     break;      /* Postpone until runtime */
2921                 }
2922
2923                 kid = kUNOP->op_first;
2924                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2925                     kid = kUNOP->op_first;
2926                 if (kid->op_type == OP_NULL)
2927                     Perl_croak(aTHX_
2928                                "Unexpected constant lvalue entersub "
2929                                "entry via type/targ %ld:%"UVuf,
2930                                (long)kid->op_type, (UV)kid->op_targ);
2931                 if (kid->op_type != OP_GV) {
2932                     break;
2933                 }
2934
2935                 gv = kGVOP_gv;
2936                 cv = isGV(gv)
2937                     ? GvCV(gv)
2938                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2939                         ? MUTABLE_CV(SvRV(gv))
2940                         : NULL;
2941                 if (!cv)
2942                     break;
2943                 if (CvLVALUE(cv))
2944                     break;
2945                 if (flags & OP_LVALUE_NO_CROAK)
2946                     return NULL;
2947
2948                 namesv = cv_name(cv, NULL, 0);
2949                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2950                                      "subroutine call of &%"SVf" in %s",
2951                                      SVfARG(namesv), PL_op_desc[type]),
2952                            SvUTF8(namesv));
2953                 return o;
2954             }
2955         }
2956         /* FALLTHROUGH */
2957     default:
2958       nomod:
2959         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2960         /* grep, foreach, subcalls, refgen */
2961         if (S_potential_mod_type(type))
2962             break;
2963         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2964                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2965                       ? "do block"
2966                       : OP_DESC(o)),
2967                      type ? PL_op_desc[type] : "local"));
2968         return o;
2969
2970     case OP_PREINC:
2971     case OP_PREDEC:
2972     case OP_POW:
2973     case OP_MULTIPLY:
2974     case OP_DIVIDE:
2975     case OP_MODULO:
2976     case OP_ADD:
2977     case OP_SUBTRACT:
2978     case OP_CONCAT:
2979     case OP_LEFT_SHIFT:
2980     case OP_RIGHT_SHIFT:
2981     case OP_BIT_AND:
2982     case OP_BIT_XOR:
2983     case OP_BIT_OR:
2984     case OP_I_MULTIPLY:
2985     case OP_I_DIVIDE:
2986     case OP_I_MODULO:
2987     case OP_I_ADD:
2988     case OP_I_SUBTRACT:
2989         if (!(o->op_flags & OPf_STACKED))
2990             goto nomod;
2991         PL_modcount++;
2992         break;
2993
2994     case OP_REPEAT:
2995         if (o->op_flags & OPf_STACKED) {
2996             PL_modcount++;
2997             break;
2998         }
2999         if (!(o->op_private & OPpREPEAT_DOLIST))
3000             goto nomod;
3001         else {
3002             const I32 mods = PL_modcount;
3003             modkids(cBINOPo->op_first, type);
3004             if (type != OP_AASSIGN)
3005                 goto nomod;
3006             kid = cBINOPo->op_last;
3007             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3008                 const IV iv = SvIV(kSVOP_sv);
3009                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3010                     PL_modcount =
3011                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3012             }
3013             else
3014                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3015         }
3016         break;
3017
3018     case OP_COND_EXPR:
3019         localize = 1;
3020         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3021             op_lvalue(kid, type);
3022         break;
3023
3024     case OP_RV2AV:
3025     case OP_RV2HV:
3026         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3027            PL_modcount = RETURN_UNLIMITED_NUMBER;
3028             return o;           /* Treat \(@foo) like ordinary list. */
3029         }
3030         /* FALLTHROUGH */
3031     case OP_RV2GV:
3032         if (scalar_mod_type(o, type))
3033             goto nomod;
3034         ref(cUNOPo->op_first, o->op_type);
3035         /* FALLTHROUGH */
3036     case OP_ASLICE:
3037     case OP_HSLICE:
3038         localize = 1;
3039         /* FALLTHROUGH */
3040     case OP_AASSIGN:
3041         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3042         if (type == OP_LEAVESUBLV && (
3043                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3044              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3045            ))
3046             o->op_private |= OPpMAYBE_LVSUB;
3047         /* FALLTHROUGH */
3048     case OP_NEXTSTATE:
3049     case OP_DBSTATE:
3050        PL_modcount = RETURN_UNLIMITED_NUMBER;
3051         break;
3052     case OP_KVHSLICE:
3053     case OP_KVASLICE:
3054     case OP_AKEYS:
3055         if (type == OP_LEAVESUBLV)
3056             o->op_private |= OPpMAYBE_LVSUB;
3057         goto nomod;
3058     case OP_AVHVSWITCH:
3059         if (type == OP_LEAVESUBLV
3060          && (o->op_private & 3) + OP_EACH == OP_KEYS)
3061             o->op_private |= OPpMAYBE_LVSUB;
3062         goto nomod;
3063     case OP_AV2ARYLEN:
3064         PL_hints |= HINT_BLOCK_SCOPE;
3065         if (type == OP_LEAVESUBLV)
3066             o->op_private |= OPpMAYBE_LVSUB;
3067         PL_modcount++;
3068         break;
3069     case OP_RV2SV:
3070         ref(cUNOPo->op_first, o->op_type);
3071         localize = 1;
3072         /* FALLTHROUGH */
3073     case OP_GV:
3074         PL_hints |= HINT_BLOCK_SCOPE;
3075         /* FALLTHROUGH */
3076     case OP_SASSIGN:
3077     case OP_ANDASSIGN:
3078     case OP_ORASSIGN:
3079     case OP_DORASSIGN:
3080         PL_modcount++;
3081         break;
3082
3083     case OP_AELEMFAST:
3084     case OP_AELEMFAST_LEX:
3085         localize = -1;
3086         PL_modcount++;
3087         break;
3088
3089     case OP_PADAV:
3090     case OP_PADHV:
3091        PL_modcount = RETURN_UNLIMITED_NUMBER;
3092         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3093             return o;           /* Treat \(@foo) like ordinary list. */
3094         if (scalar_mod_type(o, type))
3095             goto nomod;
3096         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3097           && type == OP_LEAVESUBLV)
3098             o->op_private |= OPpMAYBE_LVSUB;
3099         /* FALLTHROUGH */
3100     case OP_PADSV:
3101         PL_modcount++;
3102         if (!type) /* local() */
3103             Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3104                               PNfARG(PAD_COMPNAME(o->op_targ)));
3105         if (!(o->op_private & OPpLVAL_INTRO)
3106          || (  type != OP_SASSIGN && type != OP_AASSIGN
3107             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3108             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3109         break;
3110
3111     case OP_PUSHMARK:
3112         localize = 0;
3113         break;
3114
3115     case OP_KEYS:
3116         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3117             goto nomod;
3118         goto lvalue_func;
3119     case OP_SUBSTR:
3120         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3121             goto nomod;
3122         /* FALLTHROUGH */
3123     case OP_POS:
3124     case OP_VEC:
3125       lvalue_func:
3126         if (type == OP_LEAVESUBLV)
3127             o->op_private |= OPpMAYBE_LVSUB;
3128         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3129             /* substr and vec */
3130             /* If this op is in merely potential (non-fatal) modifiable
3131                context, then apply OP_ENTERSUB context to
3132                the kid op (to avoid croaking).  Other-
3133                wise pass this op’s own type so the correct op is mentioned
3134                in error messages.  */
3135             op_lvalue(OpSIBLING(cBINOPo->op_first),
3136                       S_potential_mod_type(type)
3137                         ? (I32)OP_ENTERSUB
3138                         : o->op_type);
3139         }
3140         break;
3141
3142     case OP_AELEM:
3143     case OP_HELEM:
3144         ref(cBINOPo->op_first, o->op_type);
3145         if (type == OP_ENTERSUB &&
3146              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3147             o->op_private |= OPpLVAL_DEFER;
3148         if (type == OP_LEAVESUBLV)
3149             o->op_private |= OPpMAYBE_LVSUB;
3150         localize = 1;
3151         PL_modcount++;
3152         break;
3153
3154     case OP_LEAVE:
3155     case OP_LEAVELOOP:
3156         o->op_private |= OPpLVALUE;
3157         /* FALLTHROUGH */
3158     case OP_SCOPE:
3159     case OP_ENTER:
3160     case OP_LINESEQ:
3161         localize = 0;
3162         if (o->op_flags & OPf_KIDS)
3163             op_lvalue(cLISTOPo->op_last, type);
3164         break;
3165
3166     case OP_NULL:
3167         localize = 0;
3168         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3169             goto nomod;
3170         else if (!(o->op_flags & OPf_KIDS))
3171             break;
3172         if (o->op_targ != OP_LIST) {
3173             op_lvalue(cBINOPo->op_first, type);
3174             break;
3175         }
3176         /* FALLTHROUGH */
3177     case OP_LIST:
3178         localize = 0;
3179         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3180             /* elements might be in void context because the list is
3181                in scalar context or because they are attribute sub calls */
3182             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3183                 op_lvalue(kid, type);
3184         break;
3185
3186     case OP_COREARGS:
3187         return o;
3188
3189     case OP_AND:
3190     case OP_OR:
3191         if (type == OP_LEAVESUBLV
3192          || !S_vivifies(cLOGOPo->op_first->op_type))
3193             op_lvalue(cLOGOPo->op_first, type);
3194         if (type == OP_LEAVESUBLV
3195          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3196             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3197         goto nomod;
3198
3199     case OP_SREFGEN:
3200         if (type == OP_NULL) { /* local */
3201           local_refgen:
3202             if (!FEATURE_MYREF_IS_ENABLED)
3203                 Perl_croak(aTHX_ "The experimental declared_refs "
3204                                  "feature is not enabled");
3205             Perl_ck_warner_d(aTHX_
3206                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3207                     "Declaring references is experimental");
3208             op_lvalue(cUNOPo->op_first, OP_NULL);
3209             return o;
3210         }
3211         if (type != OP_AASSIGN && type != OP_SASSIGN
3212          && type != OP_ENTERLOOP)
3213             goto nomod;
3214         /* Don’t bother applying lvalue context to the ex-list.  */
3215         kid = cUNOPx(cUNOPo->op_first)->op_first;
3216         assert (!OpHAS_SIBLING(kid));
3217         goto kid_2lvref;
3218     case OP_REFGEN:
3219         if (type == OP_NULL) /* local */
3220             goto local_refgen;
3221         if (type != OP_AASSIGN) goto nomod;
3222         kid = cUNOPo->op_first;
3223       kid_2lvref:
3224         {
3225             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3226             S_lvref(aTHX_ kid, type);
3227             if (!PL_parser || PL_parser->error_count == ec) {
3228                 if (!FEATURE_REFALIASING_IS_ENABLED)
3229                     Perl_croak(aTHX_
3230                        "Experimental aliasing via reference not enabled");
3231                 Perl_ck_warner_d(aTHX_
3232                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3233                                 "Aliasing via reference is experimental");
3234             }
3235         }
3236         if (o->op_type == OP_REFGEN)
3237             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3238         op_null(o);
3239         return o;
3240
3241     case OP_SPLIT:
3242         kid = cLISTOPo->op_first;
3243         if (kid && kid->op_type == OP_PUSHRE &&
3244                 (  kid->op_targ
3245                 || o->op_flags & OPf_STACKED
3246 #ifdef USE_ITHREADS
3247                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3248 #else
3249                 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3250 #endif
3251         )) {
3252             /* This is actually @array = split.  */
3253             PL_modcount = RETURN_UNLIMITED_NUMBER;
3254             break;
3255         }
3256         goto nomod;
3257
3258     case OP_SCALAR:
3259         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3260         goto nomod;
3261     }
3262
3263     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3264        their argument is a filehandle; thus \stat(".") should not set
3265        it. AMS 20011102 */
3266     if (type == OP_REFGEN &&
3267         PL_check[o->op_type] == Perl_ck_ftst)
3268         return o;
3269
3270     if (type != OP_LEAVESUBLV)
3271         o->op_flags |= OPf_MOD;
3272
3273     if (type == OP_AASSIGN || type == OP_SASSIGN)
3274         o->op_flags |= OPf_SPECIAL|OPf_REF;
3275     else if (!type) { /* local() */
3276         switch (localize) {
3277         case 1:
3278             o->op_private |= OPpLVAL_INTRO;
3279             o->op_flags &= ~OPf_SPECIAL;
3280             PL_hints |= HINT_BLOCK_SCOPE;
3281             break;
3282         case 0:
3283             break;
3284         case -1:
3285             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3286                            "Useless localization of %s", OP_DESC(o));
3287         }
3288     }
3289     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3290              && type != OP_LEAVESUBLV)
3291         o->op_flags |= OPf_REF;
3292     return o;
3293 }
3294
3295 STATIC bool
3296 S_scalar_mod_type(const OP *o, I32 type)
3297 {
3298     switch (type) {
3299     case OP_POS:
3300     case OP_SASSIGN:
3301         if (o && o->op_type == OP_RV2GV)
3302             return FALSE;
3303         /* FALLTHROUGH */
3304     case OP_PREINC:
3305     case OP_PREDEC:
3306     case OP_POSTINC:
3307     case OP_POSTDEC:
3308     case OP_I_PREINC:
3309     case OP_I_PREDEC:
3310     case OP_I_POSTINC:
3311     case OP_I_POSTDEC:
3312     case OP_POW:
3313     case OP_MULTIPLY:
3314     case OP_DIVIDE:
3315     case OP_MODULO:
3316     case OP_REPEAT:
3317     case OP_ADD:
3318     case OP_SUBTRACT:
3319     case OP_I_MULTIPLY:
3320     case OP_I_DIVIDE:
3321     case OP_I_MODULO:
3322     case OP_I_ADD:
3323     case OP_I_SUBTRACT:
3324     case OP_LEFT_SHIFT:
3325     case OP_RIGHT_SHIFT:
3326     case OP_BIT_AND:
3327     case OP_BIT_XOR:
3328     case OP_BIT_OR:
3329     case OP_NBIT_AND:
3330     case OP_NBIT_XOR:
3331     case OP_NBIT_OR:
3332     case OP_SBIT_AND:
3333     case OP_SBIT_XOR:
3334     case OP_SBIT_OR:
3335     case OP_CONCAT:
3336     case OP_SUBST:
3337     case OP_TRANS:
3338     case OP_TRANSR:
3339     case OP_READ:
3340     case OP_SYSREAD:
3341     case OP_RECV:
3342     case OP_ANDASSIGN:
3343     case OP_ORASSIGN:
3344     case OP_DORASSIGN:
3345     case OP_VEC:
3346     case OP_SUBSTR:
3347         return TRUE;
3348     default:
3349         return FALSE;
3350     }
3351 }
3352
3353 STATIC bool
3354 S_is_handle_constructor(const OP *o, I32 numargs)
3355 {
3356     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3357
3358     switch (o->op_type) {
3359     case OP_PIPE_OP:
3360     case OP_SOCKPAIR:
3361         if (numargs == 2)
3362             return TRUE;
3363         /* FALLTHROUGH */
3364     case OP_SYSOPEN:
3365     case OP_OPEN:
3366     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
3367     case OP_SOCKET:
3368     case OP_OPEN_DIR:
3369     case OP_ACCEPT:
3370         if (numargs == 1)
3371             return TRUE;
3372         /* FALLTHROUGH */
3373     default:
3374         return FALSE;
3375     }
3376 }
3377
3378 static OP *
3379 S_refkids(pTHX_ OP *o, I32 type)
3380 {
3381     if (o && o->op_flags & OPf_KIDS) {
3382         OP *kid;
3383         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3384             ref(kid, type);
3385     }
3386     return o;
3387 }
3388
3389 OP *
3390 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3391 {
3392     dVAR;
3393     OP *kid;
3394
3395     PERL_ARGS_ASSERT_DOREF;
3396
3397     if (PL_parser && PL_parser->error_count)
3398         return o;
3399
3400     switch (o->op_type) {
3401     case OP_ENTERSUB:
3402         if ((type == OP_EXISTS || type == OP_DEFINED) &&
3403             !(o->op_flags & OPf_STACKED)) {
3404             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3405             assert(cUNOPo->op_first->op_type == OP_NULL);
3406             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
3407             o->op_flags |= OPf_SPECIAL;
3408         }
3409         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3410             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3411                               : type == OP_RV2HV ? OPpDEREF_HV
3412                               : OPpDEREF_SV);
3413             o->op_flags |= OPf_MOD;
3414         }
3415
3416         break;
3417
3418     case OP_COND_EXPR:
3419         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3420             doref(kid, type, set_op_ref);
3421         break;
3422     case OP_RV2SV:
3423         if (type == OP_DEFINED)
3424             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3425         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3426         /* FALLTHROUGH */
3427     case OP_PADSV:
3428         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3429             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3430                               : type == OP_RV2HV ? OPpDEREF_HV
3431                               : OPpDEREF_SV);
3432             o->op_flags |= OPf_MOD;
3433         }
3434         break;
3435
3436     case OP_RV2AV:
3437     case OP_RV2HV:
3438         if (set_op_ref)
3439             o->op_flags |= OPf_REF;
3440         /* FALLTHROUGH */
3441     case OP_RV2GV:
3442         if (type == OP_DEFINED)
3443             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
3444         doref(cUNOPo->op_first, o->op_type, set_op_ref);
3445         break;
3446
3447     case OP_PADAV:
3448     case OP_PADHV:
3449         if (set_op_ref)
3450             o->op_flags |= OPf_REF;
3451         break;
3452
3453     case OP_SCALAR:
3454     case OP_NULL:
3455         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3456             break;
3457         doref(cBINOPo->op_first, type, set_op_ref);
3458         break;
3459     case OP_AELEM:
3460     case OP_HELEM:
3461         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3462         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3463             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3464                               : type == OP_RV2HV ? OPpDEREF_HV
3465                               : OPpDEREF_SV);
3466             o->op_flags |= OPf_MOD;
3467         }
3468         break;
3469
3470     case OP_SCOPE:
3471     case OP_LEAVE:
3472         set_op_ref = FALSE;
3473         /* FALLTHROUGH */
3474     case OP_ENTER:
3475     case OP_LIST:
3476         if (!(o->op_flags & OPf_KIDS))
3477             break;
3478         doref(cLISTOPo->op_last, type, set_op_ref);
3479         break;
3480     default:
3481         break;
3482     }
3483     return scalar(o);
3484
3485 }
3486
3487 STATIC OP *
3488 S_dup_attrlist(pTHX_ OP *o)
3489 {
3490     OP *rop;
3491
3492     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3493
3494     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3495      * where the first kid is OP_PUSHMARK and the remaining ones
3496      * are OP_CONST.  We need to push the OP_CONST values.
3497      */
3498     if (o->op_type == OP_CONST)
3499         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3500     else {
3501         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3502         rop = NULL;
3503         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3504             if (o->op_type == OP_CONST)
3505                 rop = op_append_elem(OP_LIST, rop,
3506                                   newSVOP(OP_CONST, o->op_flags,
3507                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3508         }
3509     }
3510     return rop;
3511 }
3512
3513 STATIC void
3514 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3515 {
3516     PERL_ARGS_ASSERT_APPLY_ATTRS;
3517     {
3518         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3519
3520         /* fake up C<use attributes $pkg,$rv,@attrs> */
3521
3522 #define ATTRSMODULE "attributes"
3523 #define ATTRSMODULE_PM "attributes.pm"
3524
3525         Perl_load_module(
3526           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3527           newSVpvs(ATTRSMODULE),
3528           NULL,
3529           op_prepend_elem(OP_LIST,
3530                           newSVOP(OP_CONST, 0, stashsv),
3531                           op_prepend_elem(OP_LIST,
3532                                           newSVOP(OP_CONST, 0,
3533                                                   newRV(target)),
3534                                           dup_attrlist(attrs))));
3535     }
3536 }
3537
3538 STATIC void
3539 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3540 {
3541     OP *pack, *imop, *arg;
3542     SV *meth, *stashsv, **svp;
3543
3544     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3545
3546     if (!attrs)
3547         return;
3548
3549     assert(target->op_type == OP_PADSV ||
3550            target->op_type == OP_PADHV ||
3551            target->op_type == OP_PADAV);
3552
3553     /* Ensure that attributes.pm is loaded. */
3554     /* Don't force the C<use> if we don't need it. */
3555     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3556     if (svp && *svp != &PL_sv_undef)
3557         NOOP;   /* already in %INC */
3558     else
3559         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3560                                newSVpvs(ATTRSMODULE), NULL);
3561
3562     /* Need package name for method call. */
3563     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3564
3565     /* Build up the real arg-list. */
3566     stashsv = newSVhek(HvNAME_HEK(stash));
3567
3568     arg = newOP(OP_PADSV, 0);
3569     arg->op_targ = target->op_targ;
3570     arg = op_prepend_elem(OP_LIST,
3571                        newSVOP(OP_CONST, 0, stashsv),
3572                        op_prepend_elem(OP_LIST,
3573                                     newUNOP(OP_REFGEN, 0,
3574                                             arg),
3575                                     dup_attrlist(attrs)));
3576
3577     /* Fake up a method call to import */
3578     meth = newSVpvs_share("import");
3579     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3580                    op_append_elem(OP_LIST,
3581                                op_prepend_elem(OP_LIST, pack, arg),
3582                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3583
3584     /* Combine the ops. */
3585     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3586 }
3587
3588 /*
3589 =notfor apidoc apply_attrs_string
3590
3591 Attempts to apply a list of attributes specified by the C<attrstr> and
3592 C<len> arguments to the subroutine identified by the C<cv> argument which
3593 is expected to be associated with the package identified by the C<stashpv>
3594 argument (see L<attributes>).  It gets this wrong, though, in that it
3595 does not correctly identify the boundaries of the individual attribute
3596 specifications within C<attrstr>.  This is not really intended for the
3597 public API, but has to be listed here for systems such as AIX which
3598 need an explicit export list for symbols.  (It's called from XS code
3599 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3600 to respect attribute syntax properly would be welcome.
3601
3602 =cut
3603 */
3604
3605 void
3606 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3607                         const char *attrstr, STRLEN len)
3608 {
3609     OP *attrs = NULL;
3610
3611     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3612
3613     if (!len) {
3614         len = strlen(attrstr);
3615     }
3616
3617     while (len) {
3618         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3619         if (len) {
3620             const char * const sstr = attrstr;
3621             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3622             attrs = op_append_elem(OP_LIST, attrs,
3623                                 newSVOP(OP_CONST, 0,
3624                                         newSVpvn(sstr, attrstr-sstr)));
3625         }
3626     }
3627
3628     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3629                      newSVpvs(ATTRSMODULE),
3630                      NULL, op_prepend_elem(OP_LIST,
3631                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3632                                   op_prepend_elem(OP_LIST,
3633                                                newSVOP(OP_CONST, 0,
3634                                                        newRV(MUTABLE_SV(cv))),
3635                                                attrs)));
3636 }
3637
3638 STATIC void
3639 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3640 {
3641     OP *new_proto = NULL;
3642     STRLEN pvlen;
3643     char *pv;
3644     OP *o;
3645
3646     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3647
3648     if (!*attrs)
3649         return;
3650
3651     o = *attrs;
3652     if (o->op_type == OP_CONST) {
3653         pv = SvPV(cSVOPo_sv, pvlen);
3654         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3655             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3656             SV ** const tmpo = cSVOPx_svp(o);
3657             SvREFCNT_dec(cSVOPo_sv);
3658             *tmpo = tmpsv;
3659             new_proto = o;
3660             *attrs = NULL;
3661         }
3662     } else if (o->op_type == OP_LIST) {
3663         OP * lasto;
3664         assert(o->op_flags & OPf_KIDS);
3665         lasto = cLISTOPo->op_first;
3666         assert(lasto->op_type == OP_PUSHMARK);
3667         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3668             if (o->op_type == OP_CONST) {
3669                 pv = SvPV(cSVOPo_sv, pvlen);
3670                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3671                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3672                     SV ** const tmpo = cSVOPx_svp(o);
3673                     SvREFCNT_dec(cSVOPo_sv);
3674                     *tmpo = tmpsv;
3675                     if (new_proto && ckWARN(WARN_MISC)) {
3676                         STRLEN new_len;
3677                         const char * newp = SvPV(cSVOPo_sv, new_len);
3678                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3679                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3680                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3681                         op_free(new_proto);
3682                     }
3683                     else if (new_proto)
3684                         op_free(new_proto);
3685                     new_proto = o;
3686                     /* excise new_proto from the list */
3687                     op_sibling_splice(*attrs, lasto, 1, NULL);
3688                     o = lasto;
3689                     continue;
3690                 }
3691             }
3692             lasto = o;
3693         }
3694         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3695            would get pulled in with no real need */
3696         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3697             op_free(*attrs);
3698             *attrs = NULL;
3699         }
3700     }
3701
3702     if (new_proto) {
3703         SV *svname;
3704         if (isGV(name)) {
3705             svname = sv_newmortal();
3706             gv_efullname3(svname, name, NULL);
3707         }
3708         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3709             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3710         else
3711             svname = (SV *)name;
3712         if (ckWARN(WARN_ILLEGALPROTO))
3713             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3714         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3715             STRLEN old_len, new_len;
3716             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3717             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3718
3719             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3720                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3721                 " in %"SVf,
3722                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3723                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3724                 SVfARG(svname));
3725         }
3726         if (*proto)
3727             op_free(*proto);
3728         *proto = new_proto;
3729     }
3730 }
3731
3732 static void
3733 S_cant_declare(pTHX_ OP *o)
3734 {
3735     if (o->op_type == OP_NULL
3736      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3737         o = cUNOPo->op_first;
3738     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3739                              o->op_type == OP_NULL
3740                                && o->op_flags & OPf_SPECIAL
3741                                  ? "do block"
3742                                  : OP_DESC(o),
3743                              PL_parser->in_my == KEY_our   ? "our"   :
3744                              PL_parser->in_my == KEY_state ? "state" :
3745                                                              "my"));
3746 }
3747
3748 STATIC OP *
3749 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3750 {
3751     I32 type;
3752     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3753
3754     PERL_ARGS_ASSERT_MY_KID;
3755
3756     if (!o || (PL_parser && PL_parser->error_count))
3757         return o;
3758
3759     type = o->op_type;
3760
3761     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3762         OP *kid;
3763         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3764             my_kid(kid, attrs, imopsp);
3765         return o;
3766     } else if (type == OP_UNDEF || type == OP_STUB) {
3767         return o;
3768     } else if (type == OP_RV2SV ||      /* "our" declaration */
3769                type == OP_RV2AV ||
3770                type == OP_RV2HV) {
3771         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3772             S_cant_declare(aTHX_ o);
3773         } else if (attrs) {
3774             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3775             assert(PL_parser);
3776             PL_parser->in_my = FALSE;
3777             PL_parser->in_my_stash = NULL;
3778             apply_attrs(GvSTASH(gv),
3779                         (type == OP_RV2SV ? GvSV(gv) :
3780                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3781                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3782                         attrs);
3783         }
3784         o->op_private |= OPpOUR_INTRO;
3785         return o;
3786     }
3787     else if (type == OP_REFGEN || type == OP_SREFGEN) {
3788         if (!FEATURE_MYREF_IS_ENABLED)
3789             Perl_croak(aTHX_ "The experimental declared_refs "
3790                              "feature is not enabled");
3791         Perl_ck_warner_d(aTHX_
3792              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3793             "Declaring references is experimental");
3794         /* Kid is a nulled OP_LIST, handled above.  */
3795         my_kid(cUNOPo->op_first, attrs, imopsp);
3796         return o;
3797     }
3798     else if (type != OP_PADSV &&
3799              type != OP_PADAV &&
3800              type != OP_PADHV &&
3801              type != OP_PUSHMARK)
3802     {
3803         S_cant_declare(aTHX_ o);
3804         return o;
3805     }
3806     else if (attrs && type != OP_PUSHMARK) {
3807         HV *stash;
3808
3809         assert(PL_parser);
3810         PL_parser->in_my = FALSE;
3811         PL_parser->in_my_stash = NULL;
3812
3813         /* check for C<my Dog $spot> when deciding package */
3814         stash = PAD_COMPNAME_TYPE(o->op_targ);
3815         if (!stash)
3816             stash = PL_curstash;
3817         apply_attrs_my(stash, o, attrs, imopsp);
3818     }
3819     o->op_flags |= OPf_MOD;
3820     o->op_private |= OPpLVAL_INTRO;
3821     if (stately)
3822         o->op_private |= OPpPAD_STATE;
3823     return o;
3824 }
3825
3826 OP *
3827 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3828 {
3829     OP *rops;
3830     int maybe_scalar = 0;
3831
3832     PERL_ARGS_ASSERT_MY_ATTRS;
3833
3834 /* [perl #17376]: this appears to be premature, and results in code such as
3835    C< our(%x); > executing in list mode rather than void mode */
3836 #if 0
3837     if (o->op_flags & OPf_PARENS)
3838         list(o);
3839     else
3840         maybe_scalar = 1;
3841 #else
3842     maybe_scalar = 1;
3843 #endif
3844     if (attrs)
3845         SAVEFREEOP(attrs);
3846     rops = NULL;
3847     o = my_kid(o, attrs, &rops);
3848     if (rops) {
3849         if (maybe_scalar && o->op_type == OP_PADSV) {
3850             o = scalar(op_append_list(OP_LIST, rops, o));
3851             o->op_private |= OPpLVAL_INTRO;
3852         }
3853         else {
3854             /* The listop in rops might have a pushmark at the beginning,
3855                which will mess up list assignment. */
3856             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3857             if (rops->op_type == OP_LIST && 
3858                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3859             {
3860                 OP * const pushmark = lrops->op_first;
3861                 /* excise pushmark */
3862                 op_sibling_splice(rops, NULL, 1, NULL);
3863                 op_free(pushmark);
3864             }
3865             o = op_append_list(OP_LIST, o, rops);
3866         }
3867     }
3868     PL_parser->in_my = FALSE;
3869     PL_parser->in_my_stash = NULL;
3870     return o;
3871 }
3872
3873 OP *
3874 Perl_sawparens(pTHX_ OP *o)
3875 {
3876     PERL_UNUSED_CONTEXT;
3877     if (o)
3878         o->op_flags |= OPf_PARENS;
3879     return o;
3880 }
3881
3882 OP *
3883 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3884 {
3885     OP *o;
3886     bool ismatchop = 0;
3887     const OPCODE ltype = left->op_type;
3888     const OPCODE rtype = right->op_type;
3889
3890     PERL_ARGS_ASSERT_BIND_MATCH;
3891
3892     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3893           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3894     {
3895       const char * const desc
3896           = PL_op_desc[(
3897                           rtype == OP_SUBST || rtype == OP_TRANS
3898                        || rtype == OP_TRANSR
3899                        )
3900                        ? (int)rtype : OP_MATCH];
3901       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3902       SV * const name =
3903         S_op_varname(aTHX_ left);
3904       if (name)
3905         Perl_warner(aTHX_ packWARN(WARN_MISC),
3906              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3907              desc, SVfARG(name), SVfARG(name));
3908       else {
3909         const char * const sample = (isary
3910              ? "@array" : "%hash");
3911         Perl_warner(aTHX_ packWARN(WARN_MISC),
3912              "Applying %s to %s will act on scalar(%s)",
3913              desc, sample, sample);
3914       }
3915     }
3916
3917     if (rtype == OP_CONST &&
3918         cSVOPx(right)->op_private & OPpCONST_BARE &&
3919         cSVOPx(right)->op_private & OPpCONST_STRICT)
3920     {
3921         no_bareword_allowed(right);
3922     }
3923
3924     /* !~ doesn't make sense with /r, so error on it for now */
3925     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3926         type == OP_NOT)
3927         /* diag_listed_as: Using !~ with %s doesn't make sense */
3928         yyerror("Using !~ with s///r doesn't make sense");
3929     if (rtype == OP_TRANSR && type == OP_NOT)
3930         /* diag_listed_as: Using !~ with %s doesn't make sense */
3931         yyerror("Using !~ with tr///r doesn't make sense");
3932
3933     ismatchop = (rtype == OP_MATCH ||
3934                  rtype == OP_SUBST ||
3935                  rtype == OP_TRANS || rtype == OP_TRANSR)
3936              && !(right->op_flags & OPf_SPECIAL);
3937     if (ismatchop && right->op_private & OPpTARGET_MY) {
3938         right->op_targ = 0;
3939         right->op_private &= ~OPpTARGET_MY;
3940     }
3941     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3942         if (left->op_type == OP_PADSV
3943          && !(left->op_private & OPpLVAL_INTRO))
3944         {
3945             right->op_targ = left->op_targ;
3946             op_free(left);
3947             o = right;
3948         }
3949         else {
3950             right->op_flags |= OPf_STACKED;
3951             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3952             ! (rtype == OP_TRANS &&
3953                right->op_private & OPpTRANS_IDENTICAL) &&
3954             ! (rtype == OP_SUBST &&
3955                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3956                 left = op_lvalue(left, rtype);
3957             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3958                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3959             else
3960                 o = op_prepend_elem(rtype, scalar(left), right);
3961         }
3962         if (type == OP_NOT)
3963             return newUNOP(OP_NOT, 0, scalar(o));
3964         return o;
3965     }
3966     else
3967         return bind_match(type, left,
3968                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3969 }
3970
3971 OP *
3972 Perl_invert(pTHX_ OP *o)
3973 {
3974     if (!o)
3975         return NULL;
3976     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3977 }
3978
3979 /*
3980 =for apidoc Amx|OP *|op_scope|OP *o
3981
3982 Wraps up an op tree with some additional ops so that at runtime a dynamic
3983 scope will be created.  The original ops run in the new dynamic scope,
3984 and then, provided that they exit normally, the scope will be unwound.
3985 The additional ops used to create and unwind the dynamic scope will
3986 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3987 instead if the ops are simple enough to not need the full dynamic scope
3988 structure.
3989
3990 =cut
3991 */
3992
3993 OP *
3994 Perl_op_scope(pTHX_ OP *o)
3995 {
3996     dVAR;
3997     if (o) {
3998         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3999             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4000             OpTYPE_set(o, OP_LEAVE);
4001         }
4002         else if (o->op_type == OP_LINESEQ) {
4003             OP *kid;
4004             OpTYPE_set(o, OP_SCOPE);
4005             kid = ((LISTOP*)o)->op_first;
4006             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4007                 op_null(kid);
4008
4009                 /* The following deals with things like 'do {1 for 1}' */
4010                 kid = OpSIBLING(kid);
4011                 if (kid &&
4012                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4013                     op_null(kid);
4014             }
4015         }
4016         else
4017             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4018     }
4019     return o;
4020 }
4021
4022 OP *
4023 Perl_op_unscope(pTHX_ OP *o)
4024 {
4025     if (o && o->op_type == OP_LINESEQ) {
4026         OP *kid = cLISTOPo->op_first;
4027         for(; kid; kid = OpSIBLING(kid))
4028             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4029                 op_null(kid);
4030     }
4031     return o;
4032 }
4033
4034 /*
4035 =for apidoc Am|int|block_start|int full
4036
4037 Handles compile-time scope entry.
4038 Arranges for hints to be restored on block
4039 exit and also handles pad sequence numbers to make lexical variables scope
4040 right.  Returns a savestack index for use with C<block_end>.
4041
4042 =cut
4043 */
4044
4045 int
4046 Perl_block_start(pTHX_ int full)
4047 {
4048     const int retval = PL_savestack_ix;
4049
4050     PL_compiling.cop_seq = PL_cop_seqmax;
4051     COP_SEQMAX_INC;
4052     pad_block_start(full);
4053     SAVEHINTS();
4054     PL_hints &= ~HINT_BLOCK_SCOPE;
4055     SAVECOMPILEWARNINGS();
4056     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4057     SAVEI32(PL_compiling.cop_seq);
4058     PL_compiling.cop_seq = 0;
4059
4060     CALL_BLOCK_HOOKS(bhk_start, full);
4061
4062     return retval;
4063 }
4064
4065 /*
4066 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4067
4068 Handles compile-time scope exit.  C<floor>
4069 is the savestack index returned by
4070 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4071 possibly modified.
4072
4073 =cut
4074 */
4075
4076 OP*
4077 Perl_block_end(pTHX_ I32 floor, OP *seq)
4078 {
4079     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4080     OP* retval = scalarseq(seq);
4081     OP *o;
4082
4083     /* XXX Is the null PL_parser check necessary here? */
4084     assert(PL_parser); /* Let’s find out under debugging builds.  */
4085     if (PL_parser && PL_parser->parsed_sub) {
4086         o = newSTATEOP(0, NULL, NULL);
4087         op_null(o);
4088         retval = op_append_elem(OP_LINESEQ, retval, o);
4089     }
4090
4091     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4092
4093     LEAVE_SCOPE(floor);
4094     if (needblockscope)
4095         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4096     o = pad_leavemy();
4097
4098     if (o) {
4099         /* pad_leavemy has created a sequence of introcv ops for all my
4100            subs declared in the block.  We have to replicate that list with
4101            clonecv ops, to deal with this situation:
4102
4103                sub {
4104                    my sub s1;
4105                    my sub s2;
4106                    sub s1 { state sub foo { \&s2 } }
4107                }->()
4108
4109            Originally, I was going to have introcv clone the CV and turn
4110            off the stale flag.  Since &s1 is declared before &s2, the
4111            introcv op for &s1 is executed (on sub entry) before the one for
4112            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4113            cloned, since it is a state sub) closes over &s2 and expects
4114            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4115            then &s2 is still marked stale.  Since &s1 is not active, and
4116            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4117            ble will not stay shared’ warning.  Because it is the same stub
4118            that will be used when the introcv op for &s2 is executed, clos-
4119            ing over it is safe.  Hence, we have to turn off the stale flag
4120            on all lexical subs in the block before we clone any of them.
4121            Hence, having introcv clone the sub cannot work.  So we create a
4122            list of ops like this:
4123
4124                lineseq
4125                   |
4126                   +-- introcv
4127                   |
4128                   +-- introcv
4129                   |
4130                   +-- introcv
4131                   |
4132                   .
4133                   .
4134                   .
4135                   |
4136                   +-- clonecv
4137                   |
4138                   +-- clonecv
4139                   |
4140                   +-- clonecv
4141                   |
4142                   .
4143                   .
4144                   .
4145          */
4146         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4147         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4148         for (;; kid = OpSIBLING(kid)) {
4149             OP *newkid = newOP(OP_CLONECV, 0);
4150             newkid->op_targ = kid->op_targ;
4151             o = op_append_elem(OP_LINESEQ, o, newkid);
4152             if (kid == last) break;
4153         }
4154         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4155     }
4156
4157     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4158
4159     return retval;
4160 }
4161
4162 /*
4163 =head1 Compile-time scope hooks
4164
4165 =for apidoc Aox||blockhook_register
4166
4167 Register a set of hooks to be called when the Perl lexical scope changes
4168 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4169
4170 =cut
4171 */
4172
4173 void
4174 Perl_blockhook_register(pTHX_ BHK *hk)
4175 {
4176     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4177
4178     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4179 }
4180
4181 void
4182 Perl_newPROG(pTHX_ OP *o)
4183 {
4184     PERL_ARGS_ASSERT_NEWPROG;
4185
4186     if (PL_in_eval) {
4187         PERL_CONTEXT *cx;
4188         I32 i;
4189         if (PL_eval_root)
4190                 return;
4191         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4192                                ((PL_in_eval & EVAL_KEEPERR)
4193                                 ? OPf_SPECIAL : 0), o);
4194
4195         cx = CX_CUR();
4196         assert(CxTYPE(cx) == CXt_EVAL);
4197
4198         if ((cx->blk_gimme & G_WANT) == G_VOID)
4199             scalarvoid(PL_eval_root);
4200         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4201             list(PL_eval_root);
4202         else
4203             scalar(PL_eval_root);
4204
4205         PL_eval_start = op_linklist(PL_eval_root);
4206         PL_eval_root->op_private |= OPpREFCOUNTED;
4207         OpREFCNT_set(PL_eval_root, 1);
4208         PL_eval_root->op_next = 0;
4209         i = PL_savestack_ix;
4210         SAVEFREEOP(o);
4211         ENTER;
4212         CALL_PEEP(PL_eval_start);
4213         finalize_optree(PL_eval_root);
4214         S_prune_chain_head(&PL_eval_start);
4215         LEAVE;
4216         PL_savestack_ix = i;
4217     }
4218     else {
4219         if (o->op_type == OP_STUB) {
4220             /* This block is entered if nothing is compiled for the main
4221                program. This will be the case for an genuinely empty main
4222                program, or one which only has BEGIN blocks etc, so already
4223                run and freed.
4224
4225                Historically (5.000) the guard above was !o. However, commit
4226                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4227                c71fccf11fde0068, changed perly.y so that newPROG() is now
4228                called with the output of block_end(), which returns a new
4229                OP_STUB for the case of an empty optree. ByteLoader (and
4230                maybe other things) also take this path, because they set up
4231                PL_main_start and PL_main_root directly, without generating an
4232                optree.
4233
4234                If the parsing the main program aborts (due to parse errors,
4235                or due to BEGIN or similar calling exit), then newPROG()
4236                isn't even called, and hence this code path and its cleanups
4237                are skipped. This shouldn't make a make a difference:
4238                * a non-zero return from perl_parse is a failure, and
4239                  perl_destruct() should be called immediately.
4240                * however, if exit(0) is called during the parse, then
4241                  perl_parse() returns 0, and perl_run() is called. As
4242                  PL_main_start will be NULL, perl_run() will return
4243                  promptly, and the exit code will remain 0.
4244             */
4245
4246             PL_comppad_name = 0;
4247             PL_compcv = 0;
4248             S_op_destroy(aTHX_ o);
4249             return;
4250         }
4251         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4252         PL_curcop = &PL_compiling;
4253         PL_main_start = LINKLIST(PL_main_root);
4254         PL_main_root->op_private |= OPpREFCOUNTED;
4255         OpREFCNT_set(PL_main_root, 1);
4256         PL_main_root->op_next = 0;
4257         CALL_PEEP(PL_main_start);
4258         finalize_optree(PL_main_root);
4259         S_prune_chain_head(&PL_main_start);
4260         cv_forget_slab(PL_compcv);
4261         PL_compcv = 0;
4262
4263         /* Register with debugger */
4264         if (PERLDB_INTER) {
4265             CV * const cv = get_cvs("DB::postponed", 0);
4266             if (cv) {
4267                 dSP;
4268                 PUSHMARK(SP);
4269                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4270                 PUTBACK;
4271                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4272             }
4273         }
4274     }
4275 }
4276
4277 OP *
4278 Perl_localize(pTHX_ OP *o, I32 lex)
4279 {
4280     PERL_ARGS_ASSERT_LOCALIZE;
4281
4282     if (o->op_flags & OPf_PARENS)
4283 /* [perl #17376]: this appears to be premature, and results in code such as
4284    C< our(%x); > executing in list mode rather than void mode */
4285 #if 0
4286         list(o);
4287 #else
4288         NOOP;
4289 #endif
4290     else {
4291         if ( PL_parser->bufptr > PL_parser->oldbufptr
4292             && PL_parser->bufptr[-1] == ','
4293             && ckWARN(WARN_PARENTHESIS))
4294         {
4295             char *s = PL_parser->bufptr;
4296             bool sigil = FALSE;
4297
4298             /* some heuristics to detect a potential error */
4299             while (*s && (strchr(", \t\n", *s)))
4300                 s++;
4301
4302             while (1) {
4303                 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4304                        && *++s
4305                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4306                     s++;
4307                     sigil = TRUE;
4308                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4309                         s++;
4310                     while (*s && (strchr(", \t\n", *s)))
4311                         s++;
4312                 }
4313                 else
4314                     break;
4315             }
4316             if (sigil && (*s == ';' || *s == '=')) {
4317                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4318                                 "Parentheses missing around \"%s\" list",
4319                                 lex
4320                                     ? (PL_parser->in_my == KEY_our
4321                                         ? "our"
4322                                         : PL_parser->in_my == KEY_state
4323                                             ? "state"
4324                                             : "my")
4325                                     : "local");
4326             }
4327         }
4328     }
4329     if (lex)
4330         o = my(o);
4331     else
4332         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
4333     PL_parser->in_my = FALSE;
4334     PL_parser->in_my_stash = NULL;
4335     return o;
4336 }
4337
4338 OP *
4339 Perl_jmaybe(pTHX_ OP *o)
4340 {
4341     PERL_ARGS_ASSERT_JMAYBE;
4342
4343     if (o->op_type == OP_LIST) {
4344         OP * const o2
4345             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4346         o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4347     }
4348     return o;
4349 }
4350
4351 PERL_STATIC_INLINE OP *
4352 S_op_std_init(pTHX_ OP *o)
4353 {
4354     I32 type = o->op_type;
4355
4356     PERL_ARGS_ASSERT_OP_STD_INIT;
4357
4358     if (PL_opargs[type] & OA_RETSCALAR)
4359         scalar(o);
4360     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4361         o->op_targ = pad_alloc(type, SVs_PADTMP);
4362
4363     return o;
4364 }
4365
4366 PERL_STATIC_INLINE OP *
4367 S_op_integerize(pTHX_ OP *o)
4368 {
4369     I32 type = o->op_type;
4370
4371     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4372
4373     /* integerize op. */
4374     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4375     {
4376         dVAR;
4377         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4378     }
4379
4380     if (type == OP_NEGATE)
4381         /* XXX might want a ck_negate() for this */
4382         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4383
4384     return o;
4385 }
4386
4387 static OP *
4388 S_fold_constants(pTHX_ OP *o)
4389 {
4390     dVAR;
4391     OP * VOL curop;
4392     OP *newop;
4393     VOL I32 type = o->op_type;
4394     bool is_stringify;
4395     SV * VOL sv = NULL;
4396     int ret = 0;
4397     OP *old_next;
4398     SV * const oldwarnhook = PL_warnhook;
4399     SV * const olddiehook  = PL_diehook;
4400     COP not_compiling;
4401     U8 oldwarn = PL_dowarn;
4402     I32 old_cxix;
4403     dJMPENV;
4404
4405     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4406
4407     if (!(PL_opargs[type] & OA_FOLDCONST))
4408         goto nope;
4409
4410     switch (type) {
4411     case OP_UCFIRST:
4412     case OP_LCFIRST:
4413     case OP_UC:
4414     case OP_LC:
4415     case OP_FC:
4416 #ifdef USE_LOCALE_CTYPE
4417         if (IN_LC_COMPILETIME(LC_CTYPE))
4418             goto nope;
4419 #endif
4420         break;
4421     case OP_SLT:
4422     case OP_SGT:
4423     case OP_SLE:
4424     case OP_SGE:
4425     case OP_SCMP:
4426 #ifdef USE_LOCALE_COLLATE
4427         if (IN_LC_COMPILETIME(LC_COLLATE))
4428             goto nope;
4429 #endif
4430         break;
4431     case OP_SPRINTF:
4432         /* XXX what about the numeric ops? */
4433 #ifdef USE_LOCALE_NUMERIC
4434         if (IN_LC_COMPILETIME(LC_NUMERIC))
4435             goto nope;
4436 #endif
4437         break;
4438     case OP_PACK:
4439         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4440           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4441             goto nope;
4442         {
4443             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4444             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4445             {
4446                 const char *s = SvPVX_const(sv);
4447                 while (s < SvEND(sv)) {
4448                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4449                     s++;
4450                 }
4451             }
4452         }
4453         break;
4454     case OP_REPEAT:
4455         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4456         break;
4457     case OP_SREFGEN:
4458         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4459          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4460             goto nope;
4461     }
4462
4463     if (PL_parser && PL_parser->error_count)
4464         goto nope;              /* Don't try to run w/ errors */
4465
4466     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4467         switch (curop->op_type) {
4468         case OP_CONST:
4469             if (   (curop->op_private & OPpCONST_BARE)
4470                 && (curop->op_private & OPpCONST_STRICT)) {
4471                 no_bareword_allowed(curop);
4472                 goto nope;
4473             }
4474             /* FALLTHROUGH */
4475         case OP_LIST:
4476         case OP_SCALAR:
4477         case OP_NULL:
4478         case OP_PUSHMARK:
4479             /* Foldable; move to next op in list */
4480             break;
4481
4482         default:
4483             /* No other op types are considered foldable */
4484             goto nope;
4485         }
4486     }
4487
4488     curop = LINKLIST(o);
4489     old_next = o->op_next;
4490     o->op_next = 0;
4491     PL_op = curop;
4492
4493     old_cxix = cxstack_ix;
4494     create_eval_scope(NULL, G_FAKINGEVAL);
4495
4496     /* Verify that we don't need to save it:  */
4497     assert(PL_curcop == &PL_compiling);
4498     StructCopy(&PL_compiling, &not_compiling, COP);
4499     PL_curcop = &not_compiling;
4500     /* The above ensures that we run with all the correct hints of the
4501        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4502     assert(IN_PERL_RUNTIME);
4503     PL_warnhook = PERL_WARNHOOK_FATAL;
4504     PL_diehook  = NULL;
4505     JMPENV_PUSH(ret);
4506
4507     /* Effective $^W=1.  */
4508     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4509         PL_dowarn |= G_WARN_ON;
4510
4511     switch (ret) {
4512     case 0:
4513         CALLRUNOPS(aTHX);
4514         sv = *(PL_stack_sp--);
4515         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4516             pad_swipe(o->op_targ,  FALSE);
4517         }
4518         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4519             SvREFCNT_inc_simple_void(sv);
4520             SvTEMP_off(sv);
4521         }
4522         else { assert(SvIMMORTAL(sv)); }
4523         break;
4524     case 3:
4525         /* Something tried to die.  Abandon constant folding.  */
4526         /* Pretend the error never happened.  */
4527         CLEAR_ERRSV();
4528         o->op_next = old_next;
4529         break;
4530     default:
4531         JMPENV_POP;
4532         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4533         PL_warnhook = oldwarnhook;
4534         PL_diehook  = olddiehook;
4535         /* XXX note that this croak may fail as we've already blown away
4536          * the stack - eg any nested evals */
4537         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4538     }
4539     JMPENV_POP;
4540     PL_dowarn   = oldwarn;
4541     PL_warnhook = oldwarnhook;
4542     PL_diehook  = olddiehook;
4543     PL_curcop = &PL_compiling;
4544
4545     /* if we croaked, depending on how we croaked the eval scope
4546      * may or may not have already been popped */
4547     if (cxstack_ix > old_cxix) {
4548         assert(cxstack_ix == old_cxix + 1);
4549         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4550         delete_eval_scope();
4551     }
4552     if (ret)
4553         goto nope;
4554
4555     /* OP_STRINGIFY and constant folding are used to implement qq.
4556        Here the constant folding is an implementation detail that we
4557        want to hide.  If the stringify op is itself already marked
4558        folded, however, then it is actually a folded join.  */
4559     is_stringify = type == OP_STRINGIFY && !o->op_folded;
4560     op_free(o);
4561     assert(sv);
4562     if (is_stringify)
4563         SvPADTMP_off(sv);
4564     else if (!SvIMMORTAL(sv)) {
4565         SvPADTMP_on(sv);
4566         SvREADONLY_on(sv);
4567     }
4568     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4569     if (!is_stringify) newop->op_folded = 1;
4570     return newop;
4571
4572  nope:
4573     return o;
4574 }
4575
4576 static OP *
4577 S_gen_constant_list(pTHX_ OP *o)
4578 {
4579     dVAR;
4580     OP *curop;
4581     const SSize_t oldtmps_floor = PL_tmps_floor;
4582     SV **svp;
4583     AV *av;
4584
4585     list(o);
4586     if (PL_parser && PL_parser->error_count)
4587         return o;               /* Don't attempt to run with errors */
4588
4589     curop = LINKLIST(o);
4590     o->op_next = 0;
4591     CALL_PEEP(curop);
4592     S_prune_chain_head(&curop);
4593     PL_op = curop;
4594     Perl_pp_pushmark(aTHX);
4595     CALLRUNOPS(aTHX);
4596     PL_op = curop;
4597     assert (!(curop->op_flags & OPf_SPECIAL));
4598     assert(curop->op_type == OP_RANGE);
4599     Perl_pp_anonlist(aTHX);
4600     PL_tmps_floor = oldtmps_floor;
4601
4602     OpTYPE_set(o, OP_RV2AV);
4603     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4604     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4605     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4606     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4607
4608     /* replace subtree with an OP_CONST */
4609     curop = ((UNOP*)o)->op_first;
4610     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4611     op_free(curop);
4612
4613     if (AvFILLp(av) != -1)
4614         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4615         {
4616             SvPADTMP_on(*svp);
4617             SvREADONLY_on(*svp);
4618         }
4619     LINKLIST(o);
4620     return list(o);
4621 }
4622
4623 /*
4624 =head1 Optree Manipulation Functions
4625 */
4626
4627 /* List constructors */
4628
4629 /*
4630 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4631
4632 Append an item to the list of ops contained directly within a list-type
4633 op, returning the lengthened list.  C<first> is the list-type op,
4634 and C<last> is the op to append to the list.  C<optype> specifies the
4635 intended opcode for the list.  If C<first> is not already a list of the
4636 right type, it will be upgraded into one.  If either C<first> or C<last>
4637 is null, the other is returned unchanged.
4638
4639 =cut
4640 */
4641
4642 OP *
4643 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4644 {
4645     if (!first)
4646         return last;
4647
4648     if (!last)
4649         return first;
4650
4651     if (first->op_type != (unsigned)type
4652         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4653     {
4654         return newLISTOP(type, 0, first, last);
4655     }
4656
4657     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4658     first->op_flags |= OPf_KIDS;
4659     return first;
4660 }
4661
4662 /*
4663 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4664
4665 Concatenate the lists of ops contained directly within two list-type ops,
4666 returning the combined list.  C<first> and C<last> are the list-type ops
4667 to concatenate.  C<optype> specifies the intended opcode for the list.
4668 If either C<first> or C<last> is not already a list of the right type,
4669 it will be upgraded into one.  If either C<first> or C<last> is null,
4670 the other is returned unchanged.
4671
4672 =cut
4673 */
4674
4675 OP *
4676 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4677 {
4678     if (!first)
4679         return last;
4680
4681     if (!last)
4682         return first;
4683
4684     if (first->op_type != (unsigned)type)
4685         return op_prepend_elem(type, first, last);
4686
4687     if (last->op_type != (unsigned)type)
4688         return op_append_elem(type, first, last);
4689
4690     OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4691     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4692     OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4693     first->op_flags |= (last->op_flags & OPf_KIDS);
4694
4695     S_op_destroy(aTHX_ last);
4696
4697     return first;
4698 }
4699
4700 /*
4701 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4702
4703 Prepend an item to the list of ops contained directly within a list-type
4704 op, returning the lengthened list.  C<first> is the op to prepend to the
4705 list, and C<last> is the list-type op.  C<optype> specifies the intended
4706 opcode for the list.  If C<last> is not already a list of the right type,
4707 it will be upgraded into one.  If either C<first> or C<last> is null,
4708 the other is returned unchanged.
4709
4710 =cut
4711 */
4712
4713 OP *
4714 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4715 {
4716     if (!first)
4717         return last;
4718
4719     if (!last)
4720         return first;
4721
4722     if (last->op_type == (unsigned)type) {
4723         if (type == OP_LIST) {  /* already a PUSHMARK there */
4724             /* insert 'first' after pushmark */
4725             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4726             if (!(first->op_flags & OPf_PARENS))
4727                 last->op_flags &= ~OPf_PARENS;
4728         }
4729         else
4730             op_sibling_splice(last, NULL, 0, first);
4731         last->op_flags |= OPf_KIDS;
4732         return last;
4733     }
4734
4735     return newLISTOP(type, 0, first, last);
4736 }
4737
4738 /*
4739 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4740
4741 Converts C<o> into a list op if it is not one already, and then converts it
4742 into the specified C<type>, calling its check function, allocating a target if
4743 it needs one, and folding constants.
4744
4745 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4746 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
4747 C<op_convert_list> to make it the right type.
4748
4749 =cut
4750 */
4751
4752 OP *
4753 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4754 {
4755     dVAR;
4756     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4757     if (!o || o->op_type != OP_LIST)
4758         o = force_list(o, 0);
4759     else
4760     {
4761         o->op_flags &= ~OPf_WANT;
4762         o->op_private &= ~OPpLVAL_INTRO;
4763     }
4764
4765     if (!(PL_opargs[type] & OA_MARK))
4766         op_null(cLISTOPo->op_first);
4767     else {
4768         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4769         if (kid2 && kid2->op_type == OP_COREARGS) {
4770             op_null(cLISTOPo->op_first);
4771             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4772         }
4773     }
4774
4775     OpTYPE_set(o, type);
4776     o->op_flags |= flags;
4777     if (flags & OPf_FOLDED)
4778         o->op_folded = 1;
4779
4780     o = CHECKOP(type, o);
4781     if (o->op_type != (unsigned)type)
4782         return o;
4783
4784     return fold_constants(op_integerize(op_std_init(o)));
4785 }
4786
4787 /* Constructors */
4788
4789
4790 /*
4791 =head1 Optree construction
4792
4793 =for apidoc Am|OP *|newNULLLIST
4794
4795 Constructs, checks, and returns a new C<stub> op, which represents an
4796 empty list expression.
4797
4798 =cut
4799 */
4800
4801 OP *
4802 Perl_newNULLLIST(pTHX)
4803 {
4804     return newOP(OP_STUB, 0);
4805 }
4806
4807 /* promote o and any siblings to be a list if its not already; i.e.
4808  *
4809  *  o - A - B
4810  *
4811  * becomes
4812  *
4813  *  list
4814  *    |
4815  *  pushmark - o - A - B
4816  *
4817  * If nullit it true, the list op is nulled.
4818  */
4819
4820 static OP *
4821 S_force_list(pTHX_ OP *o, bool nullit)
4822 {
4823     if (!o || o->op_type != OP_LIST) {
4824         OP *rest = NULL;
4825         if (o) {
4826             /* manually detach any siblings then add them back later */
4827             rest = OpSIBLING(o);
4828             OpLASTSIB_set(o, NULL);
4829         }
4830         o = newLISTOP(OP_LIST, 0, o, NULL);
4831         if (rest)
4832             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4833     }
4834     if (nullit)
4835         op_null(o);
4836     return o;
4837 }
4838
4839 /*
4840 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4841
4842 Constructs, checks, and returns an op of any list type.  C<type> is
4843 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4844 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
4845 supply up to two ops to be direct children of the list op; they are
4846 consumed by this function and become part of the constructed op tree.
4847
4848 For most list operators, the check function expects all the kid ops to be
4849 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4850 appropriate.  What you want to do in that case is create an op of type
4851 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4852 See L</op_convert_list> for more information.
4853
4854
4855 =cut
4856 */
4857
4858 OP *
4859 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4860 {
4861     dVAR;
4862     LISTOP *listop;
4863
4864     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4865         || type == OP_CUSTOM);
4866
4867     NewOp(1101, listop, 1, LISTOP);
4868
4869     OpTYPE_set(listop, type);
4870     if (first || last)
4871         flags |= OPf_KIDS;
4872     listop->op_flags = (U8)flags;
4873
4874     if (!last && first)
4875         last = first;
4876     else if (!first && last)
4877         first = last;
4878     else if (first)
4879         OpMORESIB_set(first, last);
4880     listop->op_first = first;
4881     listop->op_last = last;
4882     if (type == OP_LIST) {
4883         OP* const pushop = newOP(OP_PUSHMARK, 0);
4884         OpMORESIB_set(pushop, first);
4885         listop->op_first = pushop;
4886         listop->op_flags |= OPf_KIDS;
4887         if (!last)
4888             listop->op_last = pushop;
4889     }
4890     if (listop->op_last)
4891         OpLASTSIB_set(listop->op_last, (OP*)listop);
4892
4893     return CHECKOP(type, listop);
4894 }
4895
4896 /*
4897 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4898
4899 Constructs, checks, and returns an op of any base type (any type that
4900 has no extra fields).  C<type> is the opcode.  C<flags> gives the
4901 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4902 of C<op_private>.
4903
4904 =cut
4905 */
4906
4907 OP *
4908 Perl_newOP(pTHX_ I32 type, I32 flags)
4909 {
4910     dVAR;
4911     OP *o;
4912
4913     if (type == -OP_ENTEREVAL) {
4914         type = OP_ENTEREVAL;
4915         flags |= OPpEVAL_BYTES<<8;
4916     }
4917
4918     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4919         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4920         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4921         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4922
4923     NewOp(1101, o, 1, OP);
4924     OpTYPE_set(o, type);
4925     o->op_flags = (U8)flags;
4926
4927     o->op_next = o;
4928     o->op_private = (U8)(0 | (flags >> 8));
4929     if (PL_opargs[type] & OA_RETSCALAR)
4930         scalar(o);
4931     if (PL_opargs[type] & OA_TARGET)
4932         o->op_targ = pad_alloc(type, SVs_PADTMP);
4933     return CHECKOP(type, o);
4934 }
4935
4936 /*
4937 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4938
4939 Constructs, checks, and returns an op of any unary type.  C<type> is
4940 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
4941 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4942 bits, the eight bits of C<op_private>, except that the bit with value 1
4943 is automatically set.  C<first> supplies an optional op to be the direct
4944 child of the unary op; it is consumed by this function and become part
4945 of the constructed op tree.
4946
4947 =cut
4948 */
4949
4950 OP *
4951 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4952 {
4953     dVAR;
4954     UNOP *unop;
4955
4956     if (type == -OP_ENTEREVAL) {
4957         type = OP_ENTEREVAL;
4958         flags |= OPpEVAL_BYTES<<8;
4959     }
4960
4961     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4962         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4963         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4964         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4965         || type == OP_SASSIGN
4966         || type == OP_ENTERTRY
4967         || type == OP_CUSTOM
4968         || type == OP_NULL );
4969
4970     if (!first)
4971         first = newOP(OP_STUB, 0);
4972     if (PL_opargs[type] & OA_MARK)
4973         first = force_list(first, 1);
4974
4975     NewOp(1101, unop, 1, UNOP);
4976     OpTYPE_set(unop, type);
4977     unop->op_first = first;
4978     unop->op_flags = (U8)(flags | OPf_KIDS);
4979     unop->op_private = (U8)(1 | (flags >> 8));
4980
4981     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4982         OpLASTSIB_set(first, (OP*)unop);
4983
4984     unop = (UNOP*) CHECKOP(type, unop);
4985     if (unop->op_next)
4986         return (OP*)unop;
4987
4988     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4989 }
4990
4991 /*
4992 =for apidoc newUNOP_AUX
4993
4994 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4995 initialised to C<aux>
4996
4997 =cut
4998 */
4999
5000 OP *
5001 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5002 {
5003     dVAR;
5004     UNOP_AUX *unop;
5005
5006     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5007         || type == OP_CUSTOM);
5008
5009     NewOp(1101, unop, 1, UNOP_AUX);
5010     unop->op_type = (OPCODE)type;
5011     unop->op_ppaddr = PL_ppaddr[type];
5012     unop->op_first = first;
5013     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5014     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5015     unop->op_aux = aux;
5016
5017     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5018         OpLASTSIB_set(first, (OP*)unop);
5019
5020     unop = (UNOP_AUX*) CHECKOP(type, unop);
5021
5022     return op_std_init((OP *) unop);
5023 }
5024
5025 /*
5026 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5027
5028 Constructs, checks, and returns an op of method type with a method name
5029 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5030 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5031 and, shifted up eight bits, the eight bits of C<op_private>, except that
5032 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5033 op which evaluates method name; it is consumed by this function and
5034 become part of the constructed op tree.
5035 Supported optypes: C<OP_METHOD>.
5036
5037 =cut
5038 */
5039
5040 static OP*
5041 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5042     dVAR;
5043     METHOP *methop;
5044
5045     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5046         || type == OP_CUSTOM);
5047
5048     NewOp(1101, methop, 1, METHOP);
5049     if (dynamic_meth) {
5050         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5051         methop->op_flags = (U8)(flags | OPf_KIDS);
5052         methop->op_u.op_first = dynamic_meth;
5053         methop->op_private = (U8)(1 | (flags >> 8));
5054
5055         if (!OpHAS_SIBLING(dynamic_meth))
5056             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5057     }
5058     else {
5059         assert(const_meth);
5060         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5061         methop->op_u.op_meth_sv = const_meth;
5062         methop->op_private = (U8)(0 | (flags >> 8));
5063         methop->op_next = (OP*)methop;
5064     }
5065
5066 #ifdef USE_ITHREADS
5067     methop->op_rclass_targ = 0;
5068 #else
5069     methop->op_rclass_sv = NULL;
5070 #endif
5071
5072     OpTYPE_set(methop, type);
5073     return CHECKOP(type, methop);
5074 }
5075
5076 OP *
5077 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5078     PERL_ARGS_ASSERT_NEWMETHOP;
5079     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5080 }
5081
5082 /*
5083 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5084
5085 Constructs, checks, and returns an op of method type with a constant
5086 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5087 C<op_flags>, and, shifted up eight bits, the eight bits of
5088 C<op_private>.  C<const_meth> supplies a constant method name;
5089 it must be a shared COW string.
5090 Supported optypes: C<OP_METHOD_NAMED>.
5091
5092 =cut
5093 */
5094
5095 OP *
5096 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5097     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5098     return newMETHOP_internal(type, flags, NULL, const_meth);
5099 }
5100
5101 /*
5102 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5103
5104 Constructs, checks, and returns an op of any binary type.  C<type>
5105 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5106 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5107 the eight bits of C<op_private>, except that the bit with value 1 or
5108 2 is automatically set as required.  C<first> and C<last> supply up to
5109 two ops to be the direct children of the binary op; they are consumed
5110 by this function and become part of the constructed op tree.
5111
5112 =cut
5113 */
5114
5115 OP *
5116 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5117 {
5118     dVAR;
5119     BINOP *binop;
5120
5121     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5122         || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5123
5124     NewOp(1101, binop, 1, BINOP);
5125
5126     if (!first)
5127         first = newOP(OP_NULL, 0);
5128
5129     OpTYPE_set(binop, type);
5130     binop->op_first = first;
5131     binop->op_flags = (U8)(flags | OPf_KIDS);
5132     if (!last) {
5133         last = first;
5134         binop->op_private = (U8)(1 | (flags >> 8));
5135     }
5136     else {
5137         binop->op_private = (U8)(2 | (flags >> 8));
5138         OpMORESIB_set(first, last);
5139     }
5140
5141     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5142         OpLASTSIB_set(last, (OP*)binop);
5143
5144     binop->op_last = OpSIBLING(binop->op_first);
5145     if (binop->op_last)
5146         OpLASTSIB_set(binop->op_last, (OP*)binop);
5147
5148     binop = (BINOP*)CHECKOP(type, binop);
5149     if (binop->op_next || binop->op_type != (OPCODE)type)
5150         return (OP*)binop;
5151
5152     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5153 }
5154
5155 static int uvcompare(const void *a, const void *b)
5156     __attribute__nonnull__(1)
5157     __attribute__nonnull__(2)
5158     __attribute__pure__;
5159 static int uvcompare(const void *a, const void *b)
5160 {
5161     if (*((const UV *)a) < (*(const UV *)b))
5162         return -1;
5163     if (*((const UV *)a) > (*(const UV *)b))
5164         return 1;
5165     if (*((const UV *)a+1) < (*(const UV *)b+1))
5166         return -1;
5167     if (*((const UV *)a+1) > (*(const UV *)b+1))
5168         return 1;
5169     return 0;
5170 }
5171
5172 static OP *
5173 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5174 {
5175     SV * const tstr = ((SVOP*)expr)->op_sv;
5176     SV * const rstr =
5177                               ((SVOP*)repl)->op_sv;
5178     STRLEN tlen;
5179     STRLEN rlen;
5180     const U8 *t = (U8*)SvPV_const(tstr, tlen);
5181     const U8 *r = (U8*)SvPV_const(rstr, rlen);
5182     I32 i;
5183     I32 j;
5184     I32 grows = 0;
5185     short *tbl;
5186
5187     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5188     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
5189     I32 del              = o->op_private & OPpTRANS_DELETE;
5190     SV* swash;
5191
5192     PERL_ARGS_ASSERT_PMTRANS;
5193
5194     PL_hints |= HINT_BLOCK_SCOPE;
5195
5196     if (SvUTF8(tstr))
5197         o->op_private |= OPpTRANS_FROM_UTF;
5198
5199     if (SvUTF8(rstr))
5200         o->op_private |= OPpTRANS_TO_UTF;
5201
5202     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5203         SV* const listsv = newSVpvs("# comment\n");
5204         SV* transv = NULL;
5205         const U8* tend = t + tlen;
5206         const U8* rend = r + rlen;
5207         STRLEN ulen;
5208         UV tfirst = 1;
5209         UV tlast = 0;
5210         IV tdiff;
5211         STRLEN tcount = 0;
5212         UV rfirst = 1;
5213         UV rlast = 0;
5214         IV rdiff;
5215         STRLEN rcount = 0;
5216         IV diff;
5217         I32 none = 0;
5218         U32 max = 0;
5219         I32 bits;
5220         I32 havefinal = 0;
5221         U32 final = 0;
5222         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
5223         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
5224         U8* tsave = NULL;
5225         U8* rsave = NULL;
5226         const U32 flags = UTF8_ALLOW_DEFAULT;
5227
5228         if (!from_utf) {
5229             STRLEN len = tlen;
5230             t = tsave = bytes_to_utf8(t, &len);
5231             tend = t + len;
5232         }
5233         if (!to_utf && rlen) {
5234             STRLEN len = rlen;
5235             r = rsave = bytes_to_utf8(r, &len);
5236             rend = r + len;
5237         }
5238
5239 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5240  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5241  * odd.  */
5242
5243         if (complement) {
5244             U8 tmpbuf[UTF8_MAXBYTES+1];
5245             UV *cp;
5246             UV nextmin = 0;
5247             Newx(cp, 2*tlen, UV);
5248             i = 0;
5249             transv = newSVpvs("");
5250             while (t < tend) {
5251                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5252                 t += ulen;
5253                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5254                     t++;
5255                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5256                     t += ulen;
5257                 }
5258                 else {
5259                  cp[2*i+1] = cp[2*i];
5260                 }
5261                 i++;
5262             }
5263             qsort(cp, i, 2*sizeof(UV), uvcompare);
5264             for (j = 0; j < i; j++) {
5265                 UV  val = cp[2*j];
5266                 diff = val - nextmin;
5267                 if (diff > 0) {
5268                     t = uvchr_to_utf8(tmpbuf,nextmin);
5269                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5270                     if (diff > 1) {
5271                         U8  range_mark = ILLEGAL_UTF8_BYTE;
5272                         t = uvchr_to_utf8(tmpbuf, val - 1);
5273                         sv_catpvn(transv, (char *)&range_mark, 1);
5274                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5275                     }
5276                 }
5277                 val = cp[2*j+1];
5278                 if (val >= nextmin)
5279                     nextmin = val + 1;
5280             }
5281             t = uvchr_to_utf8(tmpbuf,nextmin);
5282             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5283             {
5284                 U8 range_mark = ILLEGAL_UTF8_BYTE;
5285                 sv_catpvn(transv, (char *)&range_mark, 1);
5286             }
5287             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5288             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5289             t = (const U8*)SvPVX_const(transv);
5290             tlen = SvCUR(transv);
5291             tend = t + tlen;
5292             Safefree(cp);
5293         }
5294         else if (!rlen && !del) {
5295             r = t; rlen = tlen; rend = tend;
5296         }
5297         if (!squash) {
5298                 if ((!rlen && !del) || t == r ||
5299                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5300                 {
5301                     o->op_private |= OPpTRANS_IDENTICAL;
5302                 }
5303         }
5304
5305         while (t < tend || tfirst <= tlast) {
5306             /* see if we need more "t" chars */
5307             if (tfirst > tlast) {
5308                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5309                 t += ulen;
5310                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
5311                     t++;
5312                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5313                     t += ulen;
5314                 }
5315                 else
5316                     tlast = tfirst;
5317             }
5318
5319             /* now see if we need more "r" chars */
5320             if (rfirst > rlast) {
5321                 if (r < rend) {
5322                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5323                     r += ulen;
5324                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
5325                         r++;
5326                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5327                         r += ulen;
5328                     }
5329                     else
5330                         rlast = rfirst;
5331                 }
5332                 else {
5333                     if (!havefinal++)
5334                         final = rlast;
5335                     rfirst = rlast = 0xffffffff;
5336                 }
5337             }
5338
5339             /* now see which range will peter out first, if either. */
5340             tdiff = tlast - tfirst;
5341             rdiff = rlast - rfirst;
5342             tcount += tdiff + 1;
5343             rcount += rdiff + 1;
5344
5345             if (tdiff <= rdiff)
5346                 diff = tdiff;
5347             else
5348                 diff = rdiff;
5349
5350             if (rfirst == 0xffffffff) {
5351                 diff = tdiff;   /* oops, pretend rdiff is infinite */
5352                 if (diff > 0)
5353                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5354                                    (long)tfirst, (long)tlast);
5355                 else
5356                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5357             }
5358             else {
5359                 if (diff > 0)
5360                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5361                                    (long)tfirst, (long)(tfirst + diff),
5362                                    (long)rfirst);
5363                 else
5364                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5365                                    (long)tfirst, (long)rfirst);
5366
5367                 if (rfirst + diff > max)
5368                     max = rfirst + diff;
5369                 if (!grows)
5370                     grows = (tfirst < rfirst &&
5371                              UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5372                 rfirst += diff + 1;
5373             }
5374             tfirst += diff + 1;
5375         }
5376
5377         none = ++max;
5378         if (del)
5379             del = ++max;
5380
5381         if (max > 0xffff)
5382             bits = 32;
5383         else if (max > 0xff)
5384             bits = 16;
5385         else
5386             bits = 8;
5387
5388         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5389 #ifdef USE_ITHREADS
5390         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5391         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5392         PAD_SETSV(cPADOPo->op_padix, swash);
5393         SvPADTMP_on(swash);
5394         SvREADONLY_on(swash);
5395 #else
5396         cSVOPo->op_sv = swash;
5397 #endif
5398         SvREFCNT_dec(listsv);
5399         SvREFCNT_dec(transv);
5400
5401         if (!del && havefinal && rlen)
5402             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5403                            newSVuv((UV)final), 0);
5404
5405         Safefree(tsave);
5406         Safefree(rsave);
5407
5408         tlen = tcount;
5409         rlen = rcount;
5410         if (r < rend)
5411             rlen++;
5412         else if (rlast == 0xffffffff)
5413             rlen = 0;
5414
5415         goto warnins;
5416     }
5417
5418     tbl = (short*)PerlMemShared_calloc(
5419         (o->op_private & OPpTRANS_COMPLEMENT) &&
5420             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5421         sizeof(short));
5422     cPVOPo->op_pv = (char*)tbl;
5423     if (complement) {
5424         for (i = 0; i < (I32)tlen; i++)
5425             tbl[t[i]] = -1;
5426         for (i = 0, j = 0; i < 256; i++) {
5427             if (!tbl[i]) {
5428                 if (j >= (I32)rlen) {
5429                     if (del)
5430                         tbl[i] = -2;
5431                     else if (rlen)
5432                         tbl[i] = r[j-1];
5433                     else
5434                         tbl[i] = (short)i;
5435                 }
5436                 else {
5437                     if (i < 128 && r[j] >= 128)
5438                         grows = 1;
5439                     tbl[i] = r[j++];
5440                 }
5441             }
5442         }
5443         if (!del) {
5444             if (!rlen) {
5445                 j = rlen;
5446                 if (!squash)
5447                     o->op_private |= OPpTRANS_IDENTICAL;
5448             }
5449             else if (j >= (I32)rlen)
5450                 j = rlen - 1;
5451             else {
5452                 tbl = 
5453                     (short *)
5454                     PerlMemShared_realloc(tbl,
5455                                           (0x101+rlen-j) * sizeof(short));
5456                 cPVOPo->op_pv = (char*)tbl;
5457             }
5458             tbl[0x100] = (short)(rlen - j);
5459             for (i=0; i < (I32)rlen - j; i++)
5460                 tbl[0x101+i] = r[j+i];
5461         }
5462     }
5463     else {
5464         if (!rlen && !del) {
5465             r = t; rlen = tlen;
5466             if (!squash)
5467                 o->op_private |= OPpTRANS_IDENTICAL;
5468         }
5469         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5470             o->op_private |= OPpTRANS_IDENTICAL;
5471         }
5472         for (i = 0; i < 256; i++)
5473             tbl[i] = -1;
5474         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5475             if (j >= (I32)rlen) {
5476                 if (del) {
5477                     if (tbl[t[i]] == -1)
5478                         tbl[t[i]] = -2;
5479                     continue;
5480                 }
5481                 --j;
5482             }
5483             if (tbl[t[i]] == -1) {
5484                 if (t[i] < 128 && r[j] >= 128)
5485                     grows = 1;
5486                 tbl[t[i]] = r[j];
5487             }
5488         }
5489     }
5490
5491   warnins:
5492     if(del && rlen == tlen) {
5493         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
5494     } else if(rlen > tlen && !complement) {
5495         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5496     }
5497
5498     if (grows)
5499         o->op_private |= OPpTRANS_GROWS;
5500     op_free(expr);
5501     op_free(repl);
5502
5503     return o;
5504 }
5505
5506 /*
5507 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5508
5509 Constructs, checks, and returns an op of any pattern matching type.
5510 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
5511 and, shifted up eight bits, the eight bits of C<op_private>.
5512
5513 =cut
5514 */
5515
5516 OP *
5517 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5518 {
5519     dVAR;
5520     PMOP *pmop;
5521
5522     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5523         || type == OP_CUSTOM);
5524
5525     NewOp(1101, pmop, 1, PMOP);
5526     OpTYPE_set(pmop, type);
5527     pmop->op_flags = (U8)flags;
5528     pmop->op_private = (U8)(0 | (flags >> 8));
5529     if (PL_opargs[type] & OA_RETSCALAR)
5530         scalar((OP *)pmop);
5531
5532     if (PL_hints & HINT_RE_TAINT)
5533         pmop->op_pmflags |= PMf_RETAINT;
5534 #ifdef USE_LOCALE_CTYPE
5535     if (IN_LC_COMPILETIME(LC_CTYPE)) {
5536         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5537     }
5538     else
5539 #endif
5540          if (IN_UNI_8_BIT) {
5541         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5542     }
5543     if (PL_hints & HINT_RE_FLAGS) {
5544         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5545          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5546         );
5547         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5548         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5549          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5550         );
5551         if (reflags && SvOK(reflags)) {
5552             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5553         }
5554     }
5555
5556
5557 #ifdef USE_ITHREADS
5558     assert(SvPOK(PL_regex_pad[0]));
5559     if (SvCUR(PL_regex_pad[0])) {
5560         /* Pop off the "packed" IV from the end.  */
5561         SV *const repointer_list = PL_regex_pad[0];
5562         const char *p = SvEND(repointer_list) - sizeof(IV);
5563         const IV offset = *((IV*)p);
5564
5565         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5566
5567         SvEND_set(repointer_list, p);
5568
5569         pmop->op_pmoffset = offset;
5570         /* This slot should be free, so assert this:  */
5571         assert(PL_regex_pad[offset] == &PL_sv_undef);
5572     } else {
5573         SV * const repointer = &PL_sv_undef;
5574         av_push(PL_regex_padav, repointer);
5575         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5576         PL_regex_pad = AvARRAY(PL_regex_padav);
5577     }
5578 #endif
5579
5580     return CHECKOP(type, pmop);
5581 }
5582
5583 static void
5584 S_set_haseval(pTHX)
5585 {
5586     PADOFFSET i = 1;
5587     PL_cv_has_eval = 1;
5588     /* Any pad names in scope are potentially lvalues.  */
5589     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5590         PADNAME *pn = PAD_COMPNAME_SV(i);
5591         if (!pn || !PadnameLEN(pn))
5592             continue;
5593         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5594             S_mark_padname_lvalue(aTHX_ pn);
5595     }
5596 }
5597
5598 /* Given some sort of match op o, and an expression expr containing a
5599  * pattern, either compile expr into a regex and attach it to o (if it's
5600  * constant), or convert expr into a runtime regcomp op sequence (if it's
5601  * not)
5602  *
5603  * isreg indicates that the pattern is part of a regex construct, eg
5604  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5605  * split "pattern", which aren't. In the former case, expr will be a list
5606  * if the pattern contains more than one term (eg /a$b/).
5607  *
5608  * When the pattern has been compiled within a new anon CV (for
5609  * qr/(?{...})/ ), then floor indicates the savestack level just before
5610  * the new sub was created
5611  */
5612
5613 OP *
5614 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5615 {
5616     PMOP *pm;
5617     LOGOP *rcop;
5618     I32 repl_has_vars = 0;
5619     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5620     bool is_compiletime;
5621     bool has_code;
5622
5623     PERL_ARGS_ASSERT_PMRUNTIME;
5624
5625     if (is_trans) {
5626         return pmtrans(o, expr, repl);
5627     }
5628
5629     /* find whether we have any runtime or code elements;
5630      * at the same time, temporarily set the op_next of each DO block;
5631      * then when we LINKLIST, this will cause the DO blocks to be excluded
5632      * from the op_next chain (and from having LINKLIST recursively
5633      * applied to them). We fix up the DOs specially later */
5634
5635     is_compiletime = 1;
5636     has_code = 0;
5637     if (expr->op_type == OP_LIST) {
5638         OP *o;
5639         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5640             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5641                 has_code = 1;
5642                 assert(!o->op_next);
5643                 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5644                     assert(PL_parser && PL_parser->error_count);
5645                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5646                        the op we were expecting to see, to avoid crashing
5647                        elsewhere.  */
5648                     op_sibling_splice(expr, o, 0,
5649                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5650                 }
5651                 o->op_next = OpSIBLING(o);
5652             }
5653             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5654                 is_compiletime = 0;
5655         }
5656     }
5657     else if (expr->op_type != OP_CONST)
5658         is_compiletime = 0;
5659
5660     LINKLIST(expr);
5661
5662     /* fix up DO blocks; treat each one as a separate little sub;
5663      * also, mark any arrays as LIST/REF */
5664
5665     if (expr->op_type == OP_LIST) {
5666         OP *o;
5667         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5668
5669             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5670                 assert( !(o->op_flags  & OPf_WANT));
5671                 /* push the array rather than its contents. The regex
5672                  * engine will retrieve and join the elements later */
5673                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5674                 continue;
5675             }
5676
5677             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5678                 continue;
5679             o->op_next = NULL; /* undo temporary hack from above */
5680             scalar(o);
5681             LINKLIST(o);
5682             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5683                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5684                 /* skip ENTER */
5685                 assert(leaveop->op_first->op_type == OP_ENTER);
5686                 assert(OpHAS_SIBLING(leaveop->op_first));
5687                 o->op_next = OpSIBLING(leaveop->op_first);
5688                 /* skip leave */
5689                 assert(leaveop->op_flags & OPf_KIDS);
5690                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5691                 leaveop->op_next = NULL; /* stop on last op */
5692                 op_null((OP*)leaveop);
5693             }
5694             else {
5695                 /* skip SCOPE */
5696                 OP *scope = cLISTOPo->op_first;
5697                 assert(scope->op_type == OP_SCOPE);
5698                 assert(scope->op_flags & OPf_KIDS);
5699                 scope->op_next = NULL; /* stop on last op */
5700                 op_null(scope);
5701             }
5702             /* have to peep the DOs individually as we've removed it from
5703              * the op_next chain */
5704             CALL_PEEP(o);
5705             S_prune_chain_head(&(o->op_next));
5706             if (is_compiletime)
5707                 /* runtime finalizes as part of finalizing whole tree */
5708                 finalize_optree(o);
5709         }
5710     }
5711     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5712         assert( !(expr->op_flags  & OPf_WANT));
5713         /* push the array rather than its contents. The regex
5714          * engine will retrieve and join the elements later */
5715         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5716     }
5717
5718     PL_hints |= HINT_BLOCK_SCOPE;
5719     pm = (PMOP*)o;
5720     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5721
5722     if (is_compiletime) {
5723         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5724         regexp_engine const *eng = current_re_engine();
5725
5726         if (o->op_flags & OPf_SPECIAL)
5727             rx_flags |= RXf_SPLIT;
5728
5729         if (!has_code || !eng->op_comp) {
5730             /* compile-time simple constant pattern */
5731
5732             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5733                 /* whoops! we guessed that a qr// had a code block, but we
5734                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5735                  * that isn't required now. Note that we have to be pretty
5736                  * confident that nothing used that CV's pad while the
5737                  * regex was parsed, except maybe op targets for \Q etc.
5738                  * If there were any op targets, though, they should have
5739                  * been stolen by constant folding.
5740                  */
5741 #ifdef DEBUGGING
5742                 SSize_t i = 0;
5743                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5744                 while (++i <= AvFILLp(PL_comppad)) {
5745                     assert(!PL_curpad[i]);
5746                 }
5747 #endif
5748                 /* But we know that one op is using this CV's slab. */
5749                 cv_forget_slab(PL_compcv);
5750                 LEAVE_SCOPE(floor);
5751                 pm->op_pmflags &= ~PMf_HAS_CV;
5752             }
5753
5754             PM_SETRE(pm,
5755                 eng->op_comp
5756                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5757                                         rx_flags, pm->op_pmflags)
5758                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5759                                         rx_flags, pm->op_pmflags)
5760             );
5761             op_free(expr);
5762         }
5763         else {
5764             /* compile-time pattern that includes literal code blocks */
5765             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5766                         rx_flags,
5767                         (pm->op_pmflags |
5768                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5769                     );
5770             PM_SETRE(pm, re);
5771             if (pm->op_pmflags & PMf_HAS_CV) {
5772                 CV *cv;
5773                 /* this QR op (and the anon sub we embed it in) is never
5774                  * actually executed. It's just a placeholder where we can
5775                  * squirrel away expr in op_code_list without the peephole
5776                  * optimiser etc processing it for a second time */
5777                 OP *qr = newPMOP(OP_QR, 0);
5778                 ((PMOP*)qr)->op_code_list = expr;
5779
5780                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5781                 SvREFCNT_inc_simple_void(PL_compcv);
5782                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5783                 ReANY(re)->qr_anoncv = cv;
5784
5785                 /* attach the anon CV to the pad so that
5786                  * pad_fixup_inner_anons() can find it */
5787                 (void)pad_add_anon(cv, o->op_type);
5788                 SvREFCNT_inc_simple_void(cv);
5789             }
5790             else {
5791                 pm->op_code_list = expr;
5792             }
5793         }
5794     }
5795     else {
5796         /* runtime pattern: build chain of regcomp etc ops */
5797         bool reglist;
5798         PADOFFSET cv_targ = 0;
5799
5800         reglist = isreg && expr->op_type == OP_LIST;
5801         if (reglist)
5802             op_null(expr);
5803
5804         if (has_code) {
5805             pm->op_code_list = expr;
5806             /* don't free op_code_list; its ops are embedded elsewhere too */
5807             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5808         }
5809
5810         if (o->op_flags & OPf_SPECIAL)
5811             pm->op_pmflags |= PMf_SPLIT;
5812
5813         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5814          * to allow its op_next to be pointed past the regcomp and
5815          * preceding stacking ops;
5816          * OP_REGCRESET is there to reset taint before executing the
5817          * stacking ops */
5818         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5819             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5820
5821         if (pm->op_pmflags & PMf_HAS_CV) {
5822             /* we have a runtime qr with literal code. This means
5823              * that the qr// has been wrapped in a new CV, which
5824              * means that runtime consts, vars etc will have been compiled
5825              * against a new pad. So... we need to execute those ops
5826              * within the environment of the new CV. So wrap them in a call
5827              * to a new anon sub. i.e. for
5828              *
5829              *     qr/a$b(?{...})/,
5830              *
5831              * we build an anon sub that looks like
5832              *
5833              *     sub { "a", $b, '(?{...})' }
5834              *
5835              * and call it, passing the returned list to regcomp.
5836              * Or to put it another way, the list of ops that get executed
5837              * are:
5838              *
5839              *     normal              PMf_HAS_CV
5840              *     ------              -------------------
5841              *                         pushmark (for regcomp)
5842              *                         pushmark (for entersub)
5843              *                         anoncode
5844              *                         srefgen
5845              *                         entersub
5846              *     regcreset                  regcreset
5847              *     pushmark                   pushmark
5848              *     const("a")                 const("a")
5849              *     gvsv(b)                    gvsv(b)
5850              *     const("(?{...})")          const("(?{...})")
5851              *                                leavesub
5852              *     regcomp             regcomp
5853              */
5854
5855             SvREFCNT_inc_simple_void(PL_compcv);
5856             CvLVALUE_on(PL_compcv);
5857             /* these lines are just an unrolled newANONATTRSUB */
5858             expr = newSVOP(OP_ANONCODE, 0,
5859                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5860             cv_targ = expr->op_targ;
5861             expr = newUNOP(OP_REFGEN, 0, expr);
5862
5863             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5864         }
5865
5866         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5867         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5868                            | (reglist ? OPf_STACKED : 0);
5869         rcop->op_targ = cv_targ;
5870
5871         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5872         if (PL_hints & HINT_RE_EVAL)
5873             S_set_haseval(aTHX);
5874
5875         /* establish postfix order */
5876         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5877             LINKLIST(expr);
5878             rcop->op_next = expr;
5879             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5880         }
5881         else {
5882             rcop->op_next = LINKLIST(expr);
5883             expr->op_next = (OP*)rcop;
5884         }
5885
5886         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5887     }
5888
5889     if (repl) {
5890         OP *curop = repl;
5891         bool konst;
5892         /* If we are looking at s//.../e with a single statement, get past
5893            the implicit do{}. */
5894         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5895              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5896              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5897          {
5898             OP *sib;
5899             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5900             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5901              && !OpHAS_SIBLING(sib))
5902                 curop = sib;
5903         }
5904         if (curop->op_type == OP_CONST)
5905             konst = TRUE;
5906         else if (( (curop->op_type == OP_RV2SV ||
5907                     curop->op_type == OP_RV2AV ||
5908                     curop->op_type == OP_RV2HV ||
5909                     curop->op_type == OP_RV2GV)
5910                    && cUNOPx(curop)->op_first
5911                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5912                 || curop->op_type == OP_PADSV
5913                 || curop->op_type == OP_PADAV
5914                 || curop->op_type == OP_PADHV
5915                 || curop->op_type == OP_PADANY) {
5916             repl_has_vars = 1;
5917             konst = TRUE;
5918         }
5919         else konst = FALSE;
5920         if (konst
5921             && !(repl_has_vars
5922                  && (!PM_GETRE(pm)
5923                      || !RX_PRELEN(PM_GETRE(pm))
5924                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5925         {
5926             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5927             op_prepend_elem(o->op_type, scalar(repl), o);
5928         }
5929         else {
5930             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
5931             rcop->op_private = 1;
5932
5933             /* establish postfix order */
5934             rcop->op_next = LINKLIST(repl);
5935             repl->op_next = (OP*)rcop;
5936
5937             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5938             assert(!(pm->op_pmflags & PMf_ONCE));
5939             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5940             rcop->op_next = 0;
5941         }
5942     }
5943
5944     return (OP*)pm;
5945 }
5946
5947 /*
5948 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5949
5950 Constructs, checks, and returns an op of any type that involves an
5951 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
5952 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
5953 takes ownership of one reference to it.
5954
5955 =cut
5956 */
5957
5958 OP *
5959 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5960 {
5961     dVAR;
5962     SVOP *svop;
5963
5964     PERL_ARGS_ASSERT_NEWSVOP;
5965
5966     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5967         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5968         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5969         || type == OP_CUSTOM);
5970
5971     NewOp(1101, svop, 1, SVOP);
5972     OpTYPE_set(svop, type);
5973     svop->op_sv = sv;
5974     svop->op_next = (OP*)svop;
5975     svop->op_flags = (U8)flags;
5976     svop->op_private = (U8)(0 | (flags >> 8));
5977     if (PL_opargs[type] & OA_RETSCALAR)
5978         scalar((OP*)svop);
5979     if (PL_opargs[type] & OA_TARGET)
5980         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5981     return CHECKOP(type, svop);
5982 }
5983
5984 /*
5985 =for apidoc Am|OP *|newDEFSVOP|
5986
5987 Constructs and returns an op to access C<$_>.
5988
5989 =cut
5990 */
5991
5992 OP *
5993 Perl_newDEFSVOP(pTHX)
5994 {
5995         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5996 }
5997
5998 #ifdef USE_ITHREADS
5999
6000 /*
6001 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6002
6003 Constructs, checks, and returns an op of any type that involves a
6004 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
6005 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
6006 is populated with C<sv>; this function takes ownership of one reference
6007 to it.
6008
6009 This function only exists if Perl has been compiled to use ithreads.
6010
6011 =cut
6012 */
6013
6014 OP *
6015 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6016 {
6017     dVAR;
6018     PADOP *padop;
6019
6020     PERL_ARGS_ASSERT_NEWPADOP;
6021
6022     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6023         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6024         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6025         || type == OP_CUSTOM);
6026
6027     NewOp(1101, padop, 1, PADOP);
6028     OpTYPE_set(padop, type);
6029     padop->op_padix =
6030         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6031     SvREFCNT_dec(PAD_SVl(padop->op_padix));
6032     PAD_SETSV(padop->op_padix, sv);
6033     assert(sv);
6034     padop->op_next = (OP*)padop;
6035     padop->op_flags = (U8)flags;
6036     if (PL_opargs[type] & OA_RETSCALAR)
6037         scalar((OP*)padop);
6038     if (PL_opargs[type] & OA_TARGET)
6039         padop->op_targ = pad_alloc(type, SVs_PADTMP);
6040     return CHECKOP(type, padop);
6041 }
6042
6043 #endif /* USE_ITHREADS */
6044
6045 /*
6046 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6047
6048 Constructs, checks, and returns an op of any type that involves an
6049 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
6050 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
6051 reference; calling this function does not transfer ownership of any
6052 reference to it.
6053
6054 =cut
6055 */
6056
6057 OP *
6058 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6059 {
6060     PERL_ARGS_ASSERT_NEWGVOP;
6061
6062 #ifdef USE_ITHREADS
6063     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6064 #else
6065     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6066 #endif
6067 }
6068
6069 /*
6070 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6071
6072 Constructs, checks, and returns an op of any type that involves an
6073 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
6074 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer, which
6075 must have been allocated using C<PerlMemShared_malloc>; the memory will
6076 be freed when the op is destroyed.
6077
6078 =cut
6079 */
6080
6081 OP *
6082 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6083 {
6084     dVAR;
6085     const bool utf8 = cBOOL(flags & SVf_UTF8);
6086     PVOP *pvop;
6087
6088     flags &= ~SVf_UTF8;
6089
6090     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6091         || type == OP_RUNCV || type == OP_CUSTOM
6092         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6093
6094     NewOp(1101, pvop, 1, PVOP);
6095     OpTYPE_set(pvop, type);
6096     pvop->op_pv = pv;
6097     pvop->op_next = (OP*)pvop;
6098     pvop->op_flags = (U8)flags;
6099     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6100     if (PL_opargs[type] & OA_RETSCALAR)
6101         scalar((OP*)pvop);
6102     if (PL_opargs[type] & OA_TARGET)
6103         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6104     return CHECKOP(type, pvop);
6105 }
6106
6107 void
6108 Perl_package(pTHX_ OP *o)
6109 {
6110     SV *const sv = cSVOPo->op_sv;
6111
6112     PERL_ARGS_ASSERT_PACKAGE;
6113
6114     SAVEGENERICSV(PL_curstash);
6115     save_item(PL_curstname);
6116
6117     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6118
6119     sv_setsv(PL_curstname, sv);
6120
6121     PL_hints |= HINT_BLOCK_SCOPE;
6122     PL_parser->copline = NOLINE;
6123
6124     op_free(o);
6125 }
6126
6127 void
6128 Perl_package_version( pTHX_ OP *v )
6129 {
6130     U32 savehints = PL_hints;
6131     PERL_ARGS_ASSERT_PACKAGE_VERSION;
6132     PL_hints &= ~HINT_STRICT_VARS;
6133     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6134     PL_hints = savehints;
6135     op_free(v);
6136 }
6137
6138 void
6139 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6140 {
6141     OP *pack;
6142     OP *imop;
6143     OP *veop;
6144     SV *use_version = NULL;
6145
6146     PERL_ARGS_ASSERT_UTILIZE;
6147
6148     if (idop->op_type != OP_CONST)
6149         Perl_croak(aTHX_ "Module name must be constant");
6150
6151     veop = NULL;
6152
6153     if (version) {
6154         SV * const vesv = ((SVOP*)version)->op_sv;
6155
6156         if (!arg && !SvNIOKp(vesv)) {
6157             arg = version;
6158         }
6159         else {
6160             OP *pack;
6161             SV *meth;
6162
6163             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6164                 Perl_croak(aTHX_ "Version number must be a constant number");
6165
6166             /* Make copy of idop so we don't free it twice */
6167             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6168
6169             /* Fake up a method call to VERSION */
6170             meth = newSVpvs_share("VERSION");
6171             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6172                             op_append_elem(OP_LIST,
6173                                         op_prepend_elem(OP_LIST, pack, version),
6174                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6175         }
6176     }
6177
6178     /* Fake up an import/unimport */
6179     if (arg && arg->op_type == OP_STUB) {
6180         imop = arg;             /* no import on explicit () */
6181     }
6182     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6183         imop = NULL;            /* use 5.0; */
6184         if (aver)
6185             use_version = ((SVOP*)idop)->op_sv;
6186         else
6187             idop->op_private |= OPpCONST_NOVER;
6188     }
6189     else {
6190         SV *meth;
6191
6192         /* Make copy of idop so we don't free it twice */
6193         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6194
6195         /* Fake up a method call to import/unimport */
6196         meth = aver
6197             ? newSVpvs_share("import") : newSVpvs_share("unimport");
6198         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6199                        op_append_elem(OP_LIST,
6200                                    op_prepend_elem(OP_LIST, pack, arg),
6201                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6202                        ));
6203     }
6204
6205     /* Fake up the BEGIN {}, which does its thing immediately. */
6206     newATTRSUB(floor,
6207         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6208         NULL,
6209         NULL,
6210         op_append_elem(OP_LINESEQ,
6211             op_append_elem(OP_LINESEQ,
6212                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6213                 newSTATEOP(0, NULL, veop)),
6214             newSTATEOP(0, NULL, imop) ));
6215
6216     if (use_version) {
6217         /* Enable the
6218          * feature bundle that corresponds to the required version. */
6219         use_version = sv_2mortal(new_version(use_version));
6220         S_enable_feature_bundle(aTHX_ use_version);
6221
6222         /* If a version >= 5.11.0 is requested, strictures are on by default! */
6223         if (vcmp(use_version,
6224                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6225             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6226                 PL_hints |= HINT_STRICT_REFS;
6227             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6228                 PL_hints |= HINT_STRICT_SUBS;
6229             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6230                 PL_hints |= HINT_STRICT_VARS;
6231         }
6232         /* otherwise they are off */
6233         else {
6234             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6235                 PL_hints &= ~HINT_STRICT_REFS;
6236             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6237                 PL_hints &= ~HINT_STRICT_SUBS;
6238             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6239                 PL_hints &= ~HINT_STRICT_VARS;
6240         }
6241     }
6242
6243     /* The "did you use incorrect case?" warning used to be here.
6244      * The problem is that on case-insensitive filesystems one
6245      * might get false positives for "use" (and "require"):
6246      * "use Strict" or "require CARP" will work.  This causes
6247      * portability problems for the script: in case-strict
6248      * filesystems the script will stop working.
6249      *
6250      * The "incorrect case" warning checked whether "use Foo"
6251      * imported "Foo" to your namespace, but that is wrong, too:
6252      * there is no requirement nor promise in the language that
6253      * a Foo.pm should or would contain anything in package "Foo".
6254      *
6255      * There is very little Configure-wise that can be done, either:
6256      * the case-sensitivity of the build filesystem of Perl does not
6257      * help in guessing the case-sensitivity of the runtime environment.
6258      */
6259
6260     PL_hints |= HINT_BLOCK_SCOPE;
6261     PL_parser->copline = NOLINE;
6262     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6263 }
6264
6265 /*
6266 =head1 Embedding Functions
6267
6268 =for apidoc load_module
6269
6270 Loads the module whose name is pointed to by the string part of name.
6271 Note that the actual module name, not its filename, should be given.
6272 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
6273 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6274 (or 0 for no flags).  ver, if specified
6275 and not NULL, provides version semantics
6276 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
6277 arguments can be used to specify arguments to the module's C<import()>
6278 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
6279 terminated with a final C<NULL> pointer.  Note that this list can only
6280 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6281 Otherwise at least a single C<NULL> pointer to designate the default
6282 import list is required.
6283
6284 The reference count for each specified C<SV*> parameter is decremented.
6285
6286 =cut */
6287
6288 void
6289 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6290 {
6291     va_list args;
6292
6293     PERL_ARGS_ASSERT_LOAD_MODULE;
6294
6295     va_start(args, ver);
6296     vload_module(flags, name, ver, &args);
6297     va_end(args);
6298 }
6299
6300 #ifdef PERL_IMPLICIT_CONTEXT
6301 void
6302 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6303 {
6304     dTHX;
6305     va_list args;
6306     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6307     va_start(args, ver);
6308     vload_module(flags, name, ver, &args);
6309     va_end(args);
6310 }
6311 #endif
6312
6313 void
6314 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6315 {
6316     OP *veop, *imop;
6317     OP * const modname = newSVOP(OP_CONST, 0, name);
6318
6319     PERL_ARGS_ASSERT_VLOAD_MODULE;
6320
6321     modname->op_private |= OPpCONST_BARE;
6322     if (ver) {
6323         veop = newSVOP(OP_CONST, 0, ver);
6324     }
6325     else
6326         veop = NULL;
6327     if (flags & PERL_LOADMOD_NOIMPORT) {
6328         imop = sawparens(newNULLLIST());
6329     }
6330     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6331         imop = va_arg(*args, OP*);
6332     }
6333     else {
6334         SV *sv;
6335         imop = NULL;
6336         sv = va_arg(*args, SV*);
6337         while (sv) {
6338             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6339             sv = va_arg(*args, SV*);
6340         }
6341     }
6342
6343     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6344      * that it has a PL_parser to play with while doing that, and also
6345      * that it doesn't mess with any existing parser, by creating a tmp
6346      * new parser with lex_start(). This won't actually be used for much,
6347      * since pp_require() will create another parser for the real work.
6348      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
6349
6350     ENTER;
6351     SAVEVPTR(PL_curcop);
6352     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6353     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6354             veop, modname, imop);
6355     LEAVE;
6356 }
6357
6358 PERL_STATIC_INLINE OP *
6359 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6360 {
6361     return newUNOP(OP_ENTERSUB, OPf_STACKED,
6362                    newLISTOP(OP_LIST, 0, arg,
6363                              newUNOP(OP_RV2CV, 0,
6364                                      newGVOP(OP_GV, 0, gv))));
6365 }
6366
6367 OP *
6368 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6369 {
6370     OP *doop;
6371     GV *gv;
6372
6373     PERL_ARGS_ASSERT_DOFILE;
6374
6375     if (!force_builtin && (gv = gv_override("do", 2))) {
6376         doop = S_new_entersubop(aTHX_ gv, term);
6377     }
6378     else {
6379         doop = newUNOP(OP_DOFILE, 0, scalar(term));
6380     }
6381     return doop;
6382 }
6383
6384 /*
6385 =head1 Optree construction
6386
6387 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6388
6389 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
6390 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6391 be set automatically, and, shifted up eight bits, the eight bits of
6392 C<op_private>, except that the bit with value 1 or 2 is automatically
6393 set as required.  C<listval> and C<subscript> supply the parameters of
6394 the slice; they are consumed by this function and become part of the
6395 constructed op tree.
6396
6397 =cut
6398 */
6399
6400 OP *
6401 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6402 {
6403     return newBINOP(OP_LSLICE, flags,
6404             list(force_list(subscript, 1)),
6405             list(force_list(listval,   1)) );
6406 }
6407
6408 #define ASSIGN_LIST   1
6409 #define ASSIGN_REF    2
6410
6411 STATIC I32
6412 S_assignment_type(pTHX_ const OP *o)
6413 {
6414     unsigned type;
6415     U8 flags;
6416     U8 ret;
6417
6418     if (!o)
6419         return TRUE;
6420
6421     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6422         o = cUNOPo->op_first;
6423
6424     flags = o->op_flags;
6425     type = o->op_type;
6426     if (type == OP_COND_EXPR) {
6427         OP * const sib = OpSIBLING(cLOGOPo->op_first);
6428         const I32 t = assignment_type(sib);
6429         const I32 f = assignment_type(OpSIBLING(sib));
6430
6431         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6432             return ASSIGN_LIST;
6433         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6434             yyerror("Assignment to both a list and a scalar");
6435         return FALSE;
6436     }
6437
6438     if (type == OP_SREFGEN)
6439     {
6440         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6441         type = kid->op_type;
6442         flags |= kid->op_flags;
6443         if (!(flags & OPf_PARENS)
6444           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6445               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6446             return ASSIGN_REF;
6447         ret = ASSIGN_REF;
6448     }
6449     else ret = 0;
6450
6451     if (type == OP_LIST &&
6452         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6453         o->op_private & OPpLVAL_INTRO)
6454         return ret;
6455
6456     if (type == OP_LIST || flags & OPf_PARENS ||
6457         type == OP_RV2AV || type == OP_RV2HV ||
6458         type == OP_ASLICE || type == OP_HSLICE ||
6459         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6460         return TRUE;
6461
6462     if (type == OP_PADAV || type == OP_PADHV)
6463         return TRUE;
6464
6465     if (type == OP_RV2SV)
6466         return ret;
6467
6468     return ret;
6469 }
6470
6471
6472 /*
6473 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6474
6475 Constructs, checks, and returns an assignment op.  C<left> and C<right>
6476 supply the parameters of the assignment; they are consumed by this
6477 function and become part of the constructed op tree.
6478
6479 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6480 a suitable conditional optree is constructed.  If C<optype> is the opcode
6481 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6482 performs the binary operation and assigns the result to the left argument.
6483 Either way, if C<optype> is non-zero then C<flags> has no effect.
6484
6485 If C<optype> is zero, then a plain scalar or list assignment is
6486 constructed.  Which type of assignment it is is automatically determined.
6487 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6488 will be set automatically, and, shifted up eight bits, the eight bits
6489 of C<op_private>, except that the bit with value 1 or 2 is automatically
6490 set as required.
6491
6492 =cut
6493 */
6494
6495 OP *
6496 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6497 {
6498     OP *o;
6499     I32 assign_type;
6500
6501     if (optype) {
6502         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6503             return newLOGOP(optype, 0,
6504                 op_lvalue(scalar(left), optype),
6505                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6506         }
6507         else {
6508             return newBINOP(optype, OPf_STACKED,
6509                 op_lvalue(scalar(left), optype), scalar(right));
6510         }
6511     }
6512
6513     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6514         static const char no_list_state[] = "Initialization of state variables"
6515             " in list context currently forbidden";
6516         OP *curop;
6517
6518         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6519             left->op_private &= ~ OPpSLICEWARNING;
6520
6521         PL_modcount = 0;
6522         left = op_lvalue(left, OP_AASSIGN);
6523         curop = list(force_list(left, 1));
6524         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6525         o->op_private = (U8)(0 | (flags >> 8));
6526
6527         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6528         {
6529             OP* lop = ((LISTOP*)left)->op_first;
6530             while (lop) {
6531                 if ((lop->op_type == OP_PADSV ||
6532                      lop->op_type == OP_PADAV ||
6533                      lop->op_type == OP_PADHV ||
6534                      lop->op_type == OP_PADANY)
6535                   && (lop->op_private & OPpPAD_STATE)
6536                 )
6537                     yyerror(no_list_state);
6538                 lop = OpSIBLING(lop);
6539             }
6540         }
6541         else if (  (left->op_private & OPpLVAL_INTRO)
6542                 && (left->op_private & OPpPAD_STATE)
6543                 && (   left->op_type == OP_PADSV
6544                     || left->op_type == OP_PADAV
6545                     || left->op_type == OP_PADHV
6546                     || left->op_type == OP_PADANY)
6547         ) {
6548                 /* All single variable list context state assignments, hence
6549                    state ($a) = ...
6550                    (state $a) = ...
6551                    state @a = ...
6552                    state (@a) = ...
6553                    (state @a) = ...
6554                    state %a = ...
6555                    state (%a) = ...
6556                    (state %a) = ...
6557                 */
6558                 yyerror(no_list_state);
6559         }
6560
6561         if (right && right->op_type == OP_SPLIT
6562          && !(right->op_flags & OPf_STACKED)) {
6563             OP* tmpop = ((LISTOP*)right)->op_first;
6564             PMOP * const pm = (PMOP*)tmpop;
6565             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6566             if (
6567 #ifdef USE_ITHREADS
6568                     !pm->op_pmreplrootu.op_pmtargetoff
6569 #else
6570                     !pm->op_pmreplrootu.op_pmtargetgv
6571 #endif
6572                  && !pm->op_targ
6573                 ) {
6574                     if (!(left->op_private & OPpLVAL_INTRO) &&
6575                         ( (left->op_type == OP_RV2AV &&
6576                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6577                         || left->op_type == OP_PADAV )
6578                         ) {
6579                         if (tmpop != (OP *)pm) {
6580 #ifdef USE_ITHREADS
6581                           pm->op_pmreplrootu.op_pmtargetoff
6582                             = cPADOPx(tmpop)->op_padix;
6583                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6584 #else
6585                           pm->op_pmreplrootu.op_pmtargetgv
6586                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6587                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6588 #endif
6589                           right->op_private |=
6590                             left->op_private & OPpOUR_INTRO;
6591                         }
6592                         else {
6593                             pm->op_targ = left->op_targ;
6594                             left->op_targ = 0; /* filch it */
6595                         }
6596                       detach_split:
6597                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6598                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6599                         /* detach rest of siblings from o subtree,
6600                          * and free subtree */
6601                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6602                         op_free(o);                     /* blow off assign */
6603                         right->op_flags &= ~OPf_WANT;
6604                                 /* "I don't know and I don't care." */
6605                         return right;
6606                     }
6607                     else if (left->op_type == OP_RV2AV
6608                           || left->op_type == OP_PADAV)
6609                     {
6610                         /* Detach the array.  */
6611 #ifdef DEBUGGING
6612                         OP * const ary =
6613 #endif
6614                         op_sibling_splice(cBINOPo->op_last,
6615                                           cUNOPx(cBINOPo->op_last)
6616                                                 ->op_first, 1, NULL);
6617                         assert(ary == left);
6618                         /* Attach it to the split.  */
6619                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6620                                           0, left);
6621                         right->op_flags |= OPf_STACKED;
6622                         /* Detach split and expunge aassign as above.  */
6623                         goto detach_split;
6624                     }
6625                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6626                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6627                     {
6628                         SV ** const svp =
6629                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6630                         SV * const sv = *svp;
6631                         if (SvIOK(sv) && SvIVX(sv) == 0)
6632                         {
6633                           if (right->op_private & OPpSPLIT_IMPLIM) {
6634                             /* our own SV, created in ck_split */
6635                             SvREADONLY_off(sv);
6636                             sv_setiv(sv, PL_modcount+1);
6637   &nbs