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