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