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