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