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