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