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