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