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