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