This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Inline op.c:too_many_arguments_sv into its only caller
[perl5.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 /* remove any leading "empty" ops from the op_next chain whose first
113  * node's address is stored in op_p. Store the updated address of the
114  * first node in op_p.
115  */
116
117 STATIC void
118 S_prune_chain_head(OP** op_p)
119 {
120     while (*op_p
121         && (   (*op_p)->op_type == OP_NULL
122             || (*op_p)->op_type == OP_SCOPE
123             || (*op_p)->op_type == OP_SCALAR
124             || (*op_p)->op_type == OP_LINESEQ)
125     )
126         *op_p = (*op_p)->op_next;
127 }
128
129
130 /* See the explanatory comments above struct opslab in op.h. */
131
132 #ifdef PERL_DEBUG_READONLY_OPS
133 #  define PERL_SLAB_SIZE 128
134 #  define PERL_MAX_SLAB_SIZE 4096
135 #  include <sys/mman.h>
136 #endif
137
138 #ifndef PERL_SLAB_SIZE
139 #  define PERL_SLAB_SIZE 64
140 #endif
141 #ifndef PERL_MAX_SLAB_SIZE
142 #  define PERL_MAX_SLAB_SIZE 2048
143 #endif
144
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
148
149 static OPSLAB *
150 S_new_slab(pTHX_ size_t sz)
151 {
152 #ifdef PERL_DEBUG_READONLY_OPS
153     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154                                    PROT_READ|PROT_WRITE,
155                                    MAP_ANON|MAP_PRIVATE, -1, 0);
156     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157                           (unsigned long) sz, slab));
158     if (slab == MAP_FAILED) {
159         perror("mmap failed");
160         abort();
161     }
162     slab->opslab_size = (U16)sz;
163 #else
164     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
165 #endif
166 #ifndef WIN32
167     /* The context is unused in non-Windows */
168     PERL_UNUSED_CONTEXT;
169 #endif
170     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
171     return slab;
172 }
173
174 /* requires double parens and aTHX_ */
175 #define DEBUG_S_warn(args)                                             \
176     DEBUG_S(                                                            \
177         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
178     )
179
180 void *
181 Perl_Slab_Alloc(pTHX_ size_t sz)
182 {
183     OPSLAB *slab;
184     OPSLAB *slab2;
185     OPSLOT *slot;
186     OP *o;
187     size_t opsz, space;
188
189     /* We only allocate ops from the slab during subroutine compilation.
190        We find the slab via PL_compcv, hence that must be non-NULL. It could
191        also be pointing to a subroutine which is now fully set up (CvROOT()
192        pointing to the top of the optree for that sub), or a subroutine
193        which isn't using the slab allocator. If our sanity checks aren't met,
194        don't use a slab, but allocate the OP directly from the heap.  */
195     if (!PL_compcv || CvROOT(PL_compcv)
196      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
197     {
198         o = (OP*)PerlMemShared_calloc(1, sz);
199         goto gotit;
200     }
201
202     /* While the subroutine is under construction, the slabs are accessed via
203        CvSTART(), to avoid needing to expand PVCV by one pointer for something
204        unneeded at runtime. Once a subroutine is constructed, the slabs are
205        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
207        details.  */
208     if (!CvSTART(PL_compcv)) {
209         CvSTART(PL_compcv) =
210             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211         CvSLABBED_on(PL_compcv);
212         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
213     }
214     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
215
216     opsz = SIZE_TO_PSIZE(sz);
217     sz = opsz + OPSLOT_HEADER_P;
218
219     /* The slabs maintain a free list of OPs. In particular, constant folding
220        will free up OPs, so it makes sense to re-use them where possible. A
221        freed up slot is used in preference to a new allocation.  */
222     if (slab->opslab_freed) {
223         OP **too = &slab->opslab_freed;
224         o = *too;
225         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227             DEBUG_S_warn((aTHX_ "Alas! too small"));
228             o = *(too = &o->op_next);
229             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
230         }
231         if (o) {
232             *too = o->op_next;
233             Zero(o, opsz, I32 *);
234             o->op_slabbed = 1;
235             goto gotit;
236         }
237     }
238
239 #define INIT_OPSLOT \
240             slot->opslot_slab = slab;                   \
241             slot->opslot_next = slab2->opslab_first;    \
242             slab2->opslab_first = slot;                 \
243             o = &slot->opslot_op;                       \
244             o->op_slabbed = 1
245
246     /* The partially-filled slab is next in the chain. */
247     slab2 = slab->opslab_next ? slab->opslab_next : slab;
248     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249         /* Remaining space is too small. */
250
251         /* If we can fit a BASEOP, add it to the free chain, so as not
252            to waste it. */
253         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254             slot = &slab2->opslab_slots;
255             INIT_OPSLOT;
256             o->op_type = OP_FREED;
257             o->op_next = slab->opslab_freed;
258             slab->opslab_freed = o;
259         }
260
261         /* Create a new slab.  Make this one twice as big. */
262         slot = slab2->opslab_first;
263         while (slot->opslot_next) slot = slot->opslot_next;
264         slab2 = S_new_slab(aTHX_
265                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
266                                         ? PERL_MAX_SLAB_SIZE
267                                         : (DIFF(slab2, slot)+1)*2);
268         slab2->opslab_next = slab->opslab_next;
269         slab->opslab_next = slab2;
270     }
271     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
272
273     /* Create a new op slot */
274     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275     assert(slot >= &slab2->opslab_slots);
276     if (DIFF(&slab2->opslab_slots, slot)
277          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278         slot = &slab2->opslab_slots;
279     INIT_OPSLOT;
280     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
281
282   gotit:
283     /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
284     o->op_lastsib = 1;
285     assert(!o->op_sibling);
286
287     return (void *)o;
288 }
289
290 #undef INIT_OPSLOT
291
292 #ifdef PERL_DEBUG_READONLY_OPS
293 void
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
295 {
296     PERL_ARGS_ASSERT_SLAB_TO_RO;
297
298     if (slab->opslab_readonly) return;
299     slab->opslab_readonly = 1;
300     for (; slab; slab = slab->opslab_next) {
301         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302                               (unsigned long) slab->opslab_size, slab));*/
303         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305                              (unsigned long)slab->opslab_size, errno);
306     }
307 }
308
309 void
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
311 {
312     OPSLAB *slab2;
313
314     PERL_ARGS_ASSERT_SLAB_TO_RW;
315
316     if (!slab->opslab_readonly) return;
317     slab2 = slab;
318     for (; slab2; slab2 = slab2->opslab_next) {
319         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320                               (unsigned long) size, slab2));*/
321         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322                      PROT_READ|PROT_WRITE)) {
323             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324                              (unsigned long)slab2->opslab_size, errno);
325         }
326     }
327     slab->opslab_readonly = 0;
328 }
329
330 #else
331 #  define Slab_to_rw(op)    NOOP
332 #endif
333
334 /* This cannot possibly be right, but it was copied from the old slab
335    allocator, to which it was originally added, without explanation, in
336    commit 083fcd5. */
337 #ifdef NETWARE
338 #    define PerlMemShared PerlMem
339 #endif
340
341 void
342 Perl_Slab_Free(pTHX_ void *op)
343 {
344     OP * const o = (OP *)op;
345     OPSLAB *slab;
346
347     PERL_ARGS_ASSERT_SLAB_FREE;
348
349     if (!o->op_slabbed) {
350         if (!o->op_static)
351             PerlMemShared_free(op);
352         return;
353     }
354
355     slab = OpSLAB(o);
356     /* If this op is already freed, our refcount will get screwy. */
357     assert(o->op_type != OP_FREED);
358     o->op_type = OP_FREED;
359     o->op_next = slab->opslab_freed;
360     slab->opslab_freed = o;
361     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362     OpslabREFCNT_dec_padok(slab);
363 }
364
365 void
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
367 {
368     const bool havepad = !!PL_comppad;
369     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
370     if (havepad) {
371         ENTER;
372         PAD_SAVE_SETNULLPAD();
373     }
374     opslab_free(slab);
375     if (havepad) LEAVE;
376 }
377
378 void
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
380 {
381     OPSLAB *slab2;
382     PERL_ARGS_ASSERT_OPSLAB_FREE;
383     PERL_UNUSED_CONTEXT;
384     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385     assert(slab->opslab_refcnt == 1);
386     for (; slab; slab = slab2) {
387         slab2 = slab->opslab_next;
388 #ifdef DEBUGGING
389         slab->opslab_refcnt = ~(size_t)0;
390 #endif
391 #ifdef PERL_DEBUG_READONLY_OPS
392         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
393                                                (void*)slab));
394         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395             perror("munmap failed");
396             abort();
397         }
398 #else
399         PerlMemShared_free(slab);
400 #endif
401     }
402 }
403
404 void
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
406 {
407     OPSLAB *slab2;
408     OPSLOT *slot;
409 #ifdef DEBUGGING
410     size_t savestack_count = 0;
411 #endif
412     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
413     slab2 = slab;
414     do {
415         for (slot = slab2->opslab_first;
416              slot->opslot_next;
417              slot = slot->opslot_next) {
418             if (slot->opslot_op.op_type != OP_FREED
419              && !(slot->opslot_op.op_savefree
420 #ifdef DEBUGGING
421                   && ++savestack_count
422 #endif
423                  )
424             ) {
425                 assert(slot->opslot_op.op_slabbed);
426                 op_free(&slot->opslot_op);
427                 if (slab->opslab_refcnt == 1) goto free;
428             }
429         }
430     } while ((slab2 = slab2->opslab_next));
431     /* > 1 because the CV still holds a reference count. */
432     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
433 #ifdef DEBUGGING
434         assert(savestack_count == slab->opslab_refcnt-1);
435 #endif
436         /* Remove the CV’s reference count. */
437         slab->opslab_refcnt--;
438         return;
439     }
440    free:
441     opslab_free(slab);
442 }
443
444 #ifdef PERL_DEBUG_READONLY_OPS
445 OP *
446 Perl_op_refcnt_inc(pTHX_ OP *o)
447 {
448     if(o) {
449         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450         if (slab && slab->opslab_readonly) {
451             Slab_to_rw(slab);
452             ++o->op_targ;
453             Slab_to_ro(slab);
454         } else {
455             ++o->op_targ;
456         }
457     }
458     return o;
459
460 }
461
462 PADOFFSET
463 Perl_op_refcnt_dec(pTHX_ OP *o)
464 {
465     PADOFFSET result;
466     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
467
468     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
469
470     if (slab && slab->opslab_readonly) {
471         Slab_to_rw(slab);
472         result = --o->op_targ;
473         Slab_to_ro(slab);
474     } else {
475         result = --o->op_targ;
476     }
477     return result;
478 }
479 #endif
480 /*
481  * In the following definition, the ", (OP*)0" is just to make the compiler
482  * think the expression is of the right type: croak actually does a Siglongjmp.
483  */
484 #define CHECKOP(type,o) \
485     ((PL_op_mask && PL_op_mask[type])                           \
486      ? ( op_free((OP*)o),                                       \
487          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
488          (OP*)0 )                                               \
489      : PL_check[type](aTHX_ (OP*)o))
490
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
492
493 #define CHANGE_TYPE(o,type) \
494     STMT_START {                                \
495         o->op_type = (OPCODE)type;              \
496         o->op_ppaddr = PL_ppaddr[type];         \
497     } STMT_END
498
499 STATIC SV*
500 S_gv_ename(pTHX_ GV *gv)
501 {
502     SV* const tmpsv = sv_newmortal();
503
504     PERL_ARGS_ASSERT_GV_ENAME;
505
506     gv_efullname3(tmpsv, gv, NULL);
507     return tmpsv;
508 }
509
510 STATIC OP *
511 S_no_fh_allowed(pTHX_ OP *o)
512 {
513     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
514
515     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
516                  OP_DESC(o)));
517     return o;
518 }
519
520 STATIC OP *
521 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
522 {
523     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
524     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
525     return o;
526 }
527  
528 STATIC OP *
529 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
530 {
531     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
532
533     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
534     return o;
535 }
536
537 STATIC void
538 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
539 {
540     PERL_ARGS_ASSERT_BAD_TYPE_PV;
541
542     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
543                  (int)n, name, t, OP_DESC(kid)), flags);
544 }
545
546 STATIC void
547 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
548 {
549     SV * const namesv = gv_ename(gv);
550     PERL_ARGS_ASSERT_BAD_TYPE_GV;
551  
552     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
553                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
554 }
555
556 STATIC void
557 S_no_bareword_allowed(pTHX_ OP *o)
558 {
559     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
560
561     qerror(Perl_mess(aTHX_
562                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
563                      SVfARG(cSVOPo_sv)));
564     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
565 }
566
567 /* "register" allocation */
568
569 PADOFFSET
570 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
571 {
572     PADOFFSET off;
573     const bool is_our = (PL_parser->in_my == KEY_our);
574
575     PERL_ARGS_ASSERT_ALLOCMY;
576
577     if (flags & ~SVf_UTF8)
578         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
579                    (UV)flags);
580
581     /* Until we're using the length for real, cross check that we're being
582        told the truth.  */
583     assert(strlen(name) == len);
584
585     /* complain about "my $<special_var>" etc etc */
586     if (len &&
587         !(is_our ||
588           isALPHA(name[1]) ||
589           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
590           (name[1] == '_' && (*name == '$' || len > 2))))
591     {
592         /* name[2] is true if strlen(name) > 2  */
593         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
594          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
595             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
596                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
597                               PL_parser->in_my == KEY_state ? "state" : "my"));
598         } else {
599             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
600                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
601         }
602     }
603     else if (len == 2 && name[1] == '_' && !is_our)
604         /* diag_listed_as: Use of my $_ is experimental */
605         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
606                               "Use of %s $_ is experimental",
607                                PL_parser->in_my == KEY_state
608                                  ? "state"
609                                  : "my");
610
611     /* allocate a spare slot and store the name in that slot */
612
613     off = pad_add_name_pvn(name, len,
614                        (is_our ? padadd_OUR :
615                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
616                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
617                     PL_parser->in_my_stash,
618                     (is_our
619                         /* $_ is always in main::, even with our */
620                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
621                         : NULL
622                     )
623     );
624     /* anon sub prototypes contains state vars should always be cloned,
625      * otherwise the state var would be shared between anon subs */
626
627     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
628         CvCLONE_on(PL_compcv);
629
630     return off;
631 }
632
633 /*
634 =head1 Optree Manipulation Functions
635
636 =for apidoc alloccopstash
637
638 Available only under threaded builds, this function allocates an entry in
639 C<PL_stashpad> for the stash passed to it.
640
641 =cut
642 */
643
644 #ifdef USE_ITHREADS
645 PADOFFSET
646 Perl_alloccopstash(pTHX_ HV *hv)
647 {
648     PADOFFSET off = 0, o = 1;
649     bool found_slot = FALSE;
650
651     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
652
653     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
654
655     for (; o < PL_stashpadmax; ++o) {
656         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
657         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
658             found_slot = TRUE, off = o;
659     }
660     if (!found_slot) {
661         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
662         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
663         off = PL_stashpadmax;
664         PL_stashpadmax += 10;
665     }
666
667     PL_stashpad[PL_stashpadix = off] = hv;
668     return off;
669 }
670 #endif
671
672 /* free the body of an op without examining its contents.
673  * Always use this rather than FreeOp directly */
674
675 static void
676 S_op_destroy(pTHX_ OP *o)
677 {
678     FreeOp(o);
679 }
680
681 /* Destructor */
682
683 /*
684 =for apidoc Am|void|op_free|OP *o
685
686 Free an op.  Only use this when an op is no longer linked to from any
687 optree.
688
689 =cut
690 */
691
692 void
693 Perl_op_free(pTHX_ OP *o)
694 {
695 #ifdef USE_ITHREADS
696     dVAR;
697 #endif
698     OPCODE type;
699
700     /* Though ops may be freed twice, freeing the op after its slab is a
701        big no-no. */
702     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 
703     /* During the forced freeing of ops after compilation failure, kidops
704        may be freed before their parents. */
705     if (!o || o->op_type == OP_FREED)
706         return;
707
708     type = o->op_type;
709
710     /* an op should only ever acquire op_private flags that we know about.
711      * If this fails, you may need to fix something in regen/op_private */
712     assert(!(o->op_private & ~PL_op_private_valid[type]));
713
714     if (o->op_private & OPpREFCOUNTED) {
715         switch (type) {
716         case OP_LEAVESUB:
717         case OP_LEAVESUBLV:
718         case OP_LEAVEEVAL:
719         case OP_LEAVE:
720         case OP_SCOPE:
721         case OP_LEAVEWRITE:
722             {
723             PADOFFSET refcnt;
724             OP_REFCNT_LOCK;
725             refcnt = OpREFCNT_dec(o);
726             OP_REFCNT_UNLOCK;
727             if (refcnt) {
728                 /* Need to find and remove any pattern match ops from the list
729                    we maintain for reset().  */
730                 find_and_forget_pmops(o);
731                 return;
732             }
733             }
734             break;
735         default:
736             break;
737         }
738     }
739
740     /* Call the op_free hook if it has been set. Do it now so that it's called
741      * at the right time for refcounted ops, but still before all of the kids
742      * are freed. */
743     CALL_OPFREEHOOK(o);
744
745     if (o->op_flags & OPf_KIDS) {
746         OP *kid, *nextkid;
747         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
748             nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
749             op_free(kid);
750         }
751     }
752     if (type == OP_NULL)
753         type = (OPCODE)o->op_targ;
754
755     if (o->op_slabbed)
756         Slab_to_rw(OpSLAB(o));
757
758     /* COP* is not cleared by op_clear() so that we may track line
759      * numbers etc even after null() */
760     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
761         cop_free((COP*)o);
762     }
763
764     op_clear(o);
765     FreeOp(o);
766 #ifdef DEBUG_LEAKING_SCALARS
767     if (PL_op == o)
768         PL_op = NULL;
769 #endif
770 }
771
772 void
773 Perl_op_clear(pTHX_ OP *o)
774 {
775
776     dVAR;
777
778     PERL_ARGS_ASSERT_OP_CLEAR;
779
780     switch (o->op_type) {
781     case OP_NULL:       /* Was holding old type, if any. */
782         /* FALLTHROUGH */
783     case OP_ENTERTRY:
784     case OP_ENTEREVAL:  /* Was holding hints. */
785         o->op_targ = 0;
786         break;
787     default:
788         if (!(o->op_flags & OPf_REF)
789             || (PL_check[o->op_type] != Perl_ck_ftst))
790             break;
791         /* FALLTHROUGH */
792     case OP_GVSV:
793     case OP_GV:
794     case OP_AELEMFAST:
795         {
796             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
797 #ifdef USE_ITHREADS
798                         && PL_curpad
799 #endif
800                         ? cGVOPo_gv : NULL;
801             /* It's possible during global destruction that the GV is freed
802                before the optree. Whilst the SvREFCNT_inc is happy to bump from
803                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
804                will trigger an assertion failure, because the entry to sv_clear
805                checks that the scalar is not already freed.  A check of for
806                !SvIS_FREED(gv) turns out to be invalid, because during global
807                destruction the reference count can be forced down to zero
808                (with SVf_BREAK set).  In which case raising to 1 and then
809                dropping to 0 triggers cleanup before it should happen.  I
810                *think* that this might actually be a general, systematic,
811                weakness of the whole idea of SVf_BREAK, in that code *is*
812                allowed to raise and lower references during global destruction,
813                so any *valid* code that happens to do this during global
814                destruction might well trigger premature cleanup.  */
815             bool still_valid = gv && SvREFCNT(gv);
816
817             if (still_valid)
818                 SvREFCNT_inc_simple_void(gv);
819 #ifdef USE_ITHREADS
820             if (cPADOPo->op_padix > 0) {
821                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
822                  * may still exist on the pad */
823                 pad_swipe(cPADOPo->op_padix, TRUE);
824                 cPADOPo->op_padix = 0;
825             }
826 #else
827             SvREFCNT_dec(cSVOPo->op_sv);
828             cSVOPo->op_sv = NULL;
829 #endif
830             if (still_valid) {
831                 int try_downgrade = SvREFCNT(gv) == 2;
832                 SvREFCNT_dec_NN(gv);
833                 if (try_downgrade)
834                     gv_try_downgrade(gv);
835             }
836         }
837         break;
838     case OP_METHOD_NAMED:
839     case OP_CONST:
840     case OP_HINTSEVAL:
841         SvREFCNT_dec(cSVOPo->op_sv);
842         cSVOPo->op_sv = NULL;
843 #ifdef USE_ITHREADS
844         /** Bug #15654
845           Even if op_clear does a pad_free for the target of the op,
846           pad_free doesn't actually remove the sv that exists in the pad;
847           instead it lives on. This results in that it could be reused as 
848           a target later on when the pad was reallocated.
849         **/
850         if(o->op_targ) {
851           pad_swipe(o->op_targ,1);
852           o->op_targ = 0;
853         }
854 #endif
855         break;
856     case OP_DUMP:
857     case OP_GOTO:
858     case OP_NEXT:
859     case OP_LAST:
860     case OP_REDO:
861         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
862             break;
863         /* FALLTHROUGH */
864     case OP_TRANS:
865     case OP_TRANSR:
866         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
867             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
868 #ifdef USE_ITHREADS
869             if (cPADOPo->op_padix > 0) {
870                 pad_swipe(cPADOPo->op_padix, TRUE);
871                 cPADOPo->op_padix = 0;
872             }
873 #else
874             SvREFCNT_dec(cSVOPo->op_sv);
875             cSVOPo->op_sv = NULL;
876 #endif
877         }
878         else {
879             PerlMemShared_free(cPVOPo->op_pv);
880             cPVOPo->op_pv = NULL;
881         }
882         break;
883     case OP_SUBST:
884         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
885         goto clear_pmop;
886     case OP_PUSHRE:
887 #ifdef USE_ITHREADS
888         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
889             /* No GvIN_PAD_off here, because other references may still
890              * exist on the pad */
891             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
892         }
893 #else
894         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
895 #endif
896         /* FALLTHROUGH */
897     case OP_MATCH:
898     case OP_QR:
899 clear_pmop:
900         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
901             op_free(cPMOPo->op_code_list);
902         cPMOPo->op_code_list = NULL;
903         forget_pmop(cPMOPo);
904         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
905         /* we use the same protection as the "SAFE" version of the PM_ macros
906          * here since sv_clean_all might release some PMOPs
907          * after PL_regex_padav has been cleared
908          * and the clearing of PL_regex_padav needs to
909          * happen before sv_clean_all
910          */
911 #ifdef USE_ITHREADS
912         if(PL_regex_pad) {        /* We could be in destruction */
913             const IV offset = (cPMOPo)->op_pmoffset;
914             ReREFCNT_dec(PM_GETRE(cPMOPo));
915             PL_regex_pad[offset] = &PL_sv_undef;
916             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
917                            sizeof(offset));
918         }
919 #else
920         ReREFCNT_dec(PM_GETRE(cPMOPo));
921         PM_SETRE(cPMOPo, NULL);
922 #endif
923
924         break;
925     }
926
927     if (o->op_targ > 0) {
928         pad_free(o->op_targ);
929         o->op_targ = 0;
930     }
931 }
932
933 STATIC void
934 S_cop_free(pTHX_ COP* cop)
935 {
936     PERL_ARGS_ASSERT_COP_FREE;
937
938     CopFILE_free(cop);
939     if (! specialWARN(cop->cop_warnings))
940         PerlMemShared_free(cop->cop_warnings);
941     cophh_free(CopHINTHASH_get(cop));
942     if (PL_curcop == cop)
943        PL_curcop = NULL;
944 }
945
946 STATIC void
947 S_forget_pmop(pTHX_ PMOP *const o
948               )
949 {
950     HV * const pmstash = PmopSTASH(o);
951
952     PERL_ARGS_ASSERT_FORGET_PMOP;
953
954     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
955         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
956         if (mg) {
957             PMOP **const array = (PMOP**) mg->mg_ptr;
958             U32 count = mg->mg_len / sizeof(PMOP**);
959             U32 i = count;
960
961             while (i--) {
962                 if (array[i] == o) {
963                     /* Found it. Move the entry at the end to overwrite it.  */
964                     array[i] = array[--count];
965                     mg->mg_len = count * sizeof(PMOP**);
966                     /* Could realloc smaller at this point always, but probably
967                        not worth it. Probably worth free()ing if we're the
968                        last.  */
969                     if(!count) {
970                         Safefree(mg->mg_ptr);
971                         mg->mg_ptr = NULL;
972                     }
973                     break;
974                 }
975             }
976         }
977     }
978     if (PL_curpm == o) 
979         PL_curpm = NULL;
980 }
981
982 STATIC void
983 S_find_and_forget_pmops(pTHX_ OP *o)
984 {
985     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
986
987     if (o->op_flags & OPf_KIDS) {
988         OP *kid = cUNOPo->op_first;
989         while (kid) {
990             switch (kid->op_type) {
991             case OP_SUBST:
992             case OP_PUSHRE:
993             case OP_MATCH:
994             case OP_QR:
995                 forget_pmop((PMOP*)kid);
996             }
997             find_and_forget_pmops(kid);
998             kid = OP_SIBLING(kid);
999         }
1000     }
1001 }
1002
1003 /*
1004 =for apidoc Am|void|op_null|OP *o
1005
1006 Neutralizes an op when it is no longer needed, but is still linked to from
1007 other ops.
1008
1009 =cut
1010 */
1011
1012 void
1013 Perl_op_null(pTHX_ OP *o)
1014 {
1015     dVAR;
1016
1017     PERL_ARGS_ASSERT_OP_NULL;
1018
1019     if (o->op_type == OP_NULL)
1020         return;
1021     op_clear(o);
1022     o->op_targ = o->op_type;
1023     o->op_type = OP_NULL;
1024     o->op_ppaddr = PL_ppaddr[OP_NULL];
1025 }
1026
1027 void
1028 Perl_op_refcnt_lock(pTHX)
1029 {
1030 #ifdef USE_ITHREADS
1031     dVAR;
1032 #endif
1033     PERL_UNUSED_CONTEXT;
1034     OP_REFCNT_LOCK;
1035 }
1036
1037 void
1038 Perl_op_refcnt_unlock(pTHX)
1039 {
1040 #ifdef USE_ITHREADS
1041     dVAR;
1042 #endif
1043     PERL_UNUSED_CONTEXT;
1044     OP_REFCNT_UNLOCK;
1045 }
1046
1047
1048 /*
1049 =for apidoc op_sibling_splice
1050
1051 A general function for editing the structure of an existing chain of
1052 op_sibling nodes. By analogy with the perl-level splice() function, allows
1053 you to delete zero or more sequential nodes, replacing them with zero or
1054 more different nodes.  Performs the necessary op_first/op_last
1055 housekeeping on the parent node and op_sibling manipulation on the
1056 children. The last deleted node will be marked as as the last node by
1057 updating the op_sibling or op_lastsib field as appropriate.
1058
1059 Note that op_next is not manipulated, and nodes are not freed; that is the
1060 responsibility of the caller. It also won't create a new list op for an
1061 empty list etc; use higher-level functions like op_append_elem() for that.
1062
1063 parent is the parent node of the sibling chain.
1064
1065 start is the node preceding the first node to be spliced. Node(s)
1066 following it will be deleted, and ops will be inserted after it. If it is
1067 NULL, the first node onwards is deleted, and nodes are inserted at the
1068 beginning.
1069
1070 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1071 If -1 or greater than or equal to the number of remaining kids, all
1072 remaining kids are deleted.
1073
1074 insert is the first of a chain of nodes to be inserted in place of the nodes.
1075 If NULL, no nodes are inserted.
1076
1077 The head of the chain of deleted ops is returned, or NULL if no ops were
1078 deleted.
1079
1080 For example:
1081
1082     action                    before      after         returns
1083     ------                    -----       -----         -------
1084
1085                               P           P
1086     splice(P, A, 2, X-Y-Z)    |           |             B-C
1087                               A-B-C-D     A-X-Y-Z-D
1088
1089                               P           P
1090     splice(P, NULL, 1, X-Y)   |           |             A
1091                               A-B-C-D     X-Y-B-C-D
1092
1093                               P           P
1094     splice(P, NULL, 3, NULL)  |           |             A-B-C
1095                               A-B-C-D     D
1096
1097                               P           P
1098     splice(P, B, 0, X-Y)      |           |             NULL
1099                               A-B-C-D     A-B-X-Y-C-D
1100
1101 =cut
1102 */
1103
1104 OP *
1105 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1106 {
1107     OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1108     OP *rest;
1109     OP *last_del = NULL;
1110     OP *last_ins = NULL;
1111
1112     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1113
1114     assert(del_count >= -1);
1115
1116     if (del_count && first) {
1117         last_del = first;
1118         while (--del_count && OP_HAS_SIBLING(last_del))
1119             last_del = OP_SIBLING(last_del);
1120         rest = OP_SIBLING(last_del);
1121         OP_SIBLING_set(last_del, NULL);
1122         last_del->op_lastsib = 1;
1123     }
1124     else
1125         rest = first;
1126
1127     if (insert) {
1128         last_ins = insert;
1129         while (OP_HAS_SIBLING(last_ins))
1130             last_ins = OP_SIBLING(last_ins);
1131         OP_SIBLING_set(last_ins, rest);
1132         last_ins->op_lastsib = rest ? 0 : 1;
1133     }
1134     else
1135         insert = rest;
1136
1137     if (start) {
1138         OP_SIBLING_set(start, insert);
1139         start->op_lastsib = insert ? 0 : 1;
1140     }
1141     else
1142         cLISTOPx(parent)->op_first = insert;
1143
1144     if (!rest) {
1145         /* update op_last etc */
1146         U32 type = parent->op_type;
1147         OP *lastop;
1148
1149         if (type == OP_NULL)
1150             type = parent->op_targ;
1151         type = PL_opargs[type] & OA_CLASS_MASK;
1152
1153         lastop = last_ins ? last_ins : start ? start : NULL;
1154         if (   type == OA_BINOP
1155             || type == OA_LISTOP
1156             || type == OA_PMOP
1157             || type == OA_LOOP
1158         )
1159             cLISTOPx(parent)->op_last = lastop;
1160
1161         if (lastop) {
1162             lastop->op_lastsib = 1;
1163 #ifdef PERL_OP_PARENT
1164             lastop->op_sibling = parent;
1165 #endif
1166         }
1167     }
1168     return last_del ? first : NULL;
1169 }
1170
1171 /*
1172 =for apidoc op_parent
1173
1174 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1175 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1176 work.
1177
1178 =cut
1179 */
1180
1181 OP *
1182 Perl_op_parent(OP *o)
1183 {
1184     PERL_ARGS_ASSERT_OP_PARENT;
1185 #ifdef PERL_OP_PARENT
1186     while (OP_HAS_SIBLING(o))
1187         o = OP_SIBLING(o);
1188     return o->op_sibling;
1189 #else
1190     PERL_UNUSED_ARG(o);
1191     return NULL;
1192 #endif
1193 }
1194
1195
1196 /* replace the sibling following start with a new UNOP, which becomes
1197  * the parent of the original sibling; e.g.
1198  *
1199  *  op_sibling_newUNOP(P, A, unop-args...)
1200  *
1201  *  P              P
1202  *  |      becomes |
1203  *  A-B-C          A-U-C
1204  *                   |
1205  *                   B
1206  *
1207  * where U is the new UNOP.
1208  *
1209  * parent and start args are the same as for op_sibling_splice();
1210  * type and flags args are as newUNOP().
1211  *
1212  * Returns the new UNOP.
1213  */
1214
1215 OP *
1216 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1217 {
1218     OP *kid, *newop;
1219
1220     kid = op_sibling_splice(parent, start, 1, NULL);
1221     newop = newUNOP(type, flags, kid);
1222     op_sibling_splice(parent, start, 0, newop);
1223     return newop;
1224 }
1225
1226
1227 /* lowest-level newLOGOP-style function - just allocates and populates
1228  * the struct. Higher-level stuff should be done by S_new_logop() /
1229  * newLOGOP(). This function exists mainly to avoid op_first assignment
1230  * being spread throughout this file.
1231  */
1232
1233 LOGOP *
1234 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1235 {
1236     LOGOP *logop;
1237     OP *kid = first;
1238     NewOp(1101, logop, 1, LOGOP);
1239     logop->op_type = (OPCODE)type;
1240     logop->op_first = first;
1241     logop->op_other = other;
1242     logop->op_flags = OPf_KIDS;
1243     while (kid && OP_HAS_SIBLING(kid))
1244         kid = OP_SIBLING(kid);
1245     if (kid) {
1246         kid->op_lastsib = 1;
1247 #ifdef PERL_OP_PARENT
1248         kid->op_sibling = (OP*)logop;
1249 #endif
1250     }
1251     return logop;
1252 }
1253
1254
1255 /* Contextualizers */
1256
1257 /*
1258 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1259
1260 Applies a syntactic context to an op tree representing an expression.
1261 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1262 or C<G_VOID> to specify the context to apply.  The modified op tree
1263 is returned.
1264
1265 =cut
1266 */
1267
1268 OP *
1269 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1270 {
1271     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1272     switch (context) {
1273         case G_SCALAR: return scalar(o);
1274         case G_ARRAY:  return list(o);
1275         case G_VOID:   return scalarvoid(o);
1276         default:
1277             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1278                        (long) context);
1279     }
1280 }
1281
1282 /*
1283
1284 =for apidoc Am|OP*|op_linklist|OP *o
1285 This function is the implementation of the L</LINKLIST> macro.  It should
1286 not be called directly.
1287
1288 =cut
1289 */
1290
1291 OP *
1292 Perl_op_linklist(pTHX_ OP *o)
1293 {
1294     OP *first;
1295
1296     PERL_ARGS_ASSERT_OP_LINKLIST;
1297
1298     if (o->op_next)
1299         return o->op_next;
1300
1301     /* establish postfix order */
1302     first = cUNOPo->op_first;
1303     if (first) {
1304         OP *kid;
1305         o->op_next = LINKLIST(first);
1306         kid = first;
1307         for (;;) {
1308             OP *sibl = OP_SIBLING(kid);
1309             if (sibl) {
1310                 kid->op_next = LINKLIST(sibl);
1311                 kid = sibl;
1312             } else {
1313                 kid->op_next = o;
1314                 break;
1315             }
1316         }
1317     }
1318     else
1319         o->op_next = o;
1320
1321     return o->op_next;
1322 }
1323
1324 static OP *
1325 S_scalarkids(pTHX_ OP *o)
1326 {
1327     if (o && o->op_flags & OPf_KIDS) {
1328         OP *kid;
1329         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1330             scalar(kid);
1331     }
1332     return o;
1333 }
1334
1335 STATIC OP *
1336 S_scalarboolean(pTHX_ OP *o)
1337 {
1338     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1339
1340     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1341      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1342         if (ckWARN(WARN_SYNTAX)) {
1343             const line_t oldline = CopLINE(PL_curcop);
1344
1345             if (PL_parser && PL_parser->copline != NOLINE) {
1346                 /* This ensures that warnings are reported at the first line
1347                    of the conditional, not the last.  */
1348                 CopLINE_set(PL_curcop, PL_parser->copline);
1349             }
1350             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1351             CopLINE_set(PL_curcop, oldline);
1352         }
1353     }
1354     return scalar(o);
1355 }
1356
1357 static SV *
1358 S_op_varname(pTHX_ const OP *o)
1359 {
1360     assert(o);
1361     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1362            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1363     {
1364         const char funny  = o->op_type == OP_PADAV
1365                          || o->op_type == OP_RV2AV ? '@' : '%';
1366         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1367             GV *gv;
1368             if (cUNOPo->op_first->op_type != OP_GV
1369              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1370                 return NULL;
1371             return varname(gv, funny, 0, NULL, 0, 1);
1372         }
1373         return
1374             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1375     }
1376 }
1377
1378 static void
1379 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1380 { /* or not so pretty :-) */
1381     if (o->op_type == OP_CONST) {
1382         *retsv = cSVOPo_sv;
1383         if (SvPOK(*retsv)) {
1384             SV *sv = *retsv;
1385             *retsv = sv_newmortal();
1386             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1387                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1388         }
1389         else if (!SvOK(*retsv))
1390             *retpv = "undef";
1391     }
1392     else *retpv = "...";
1393 }
1394
1395 static void
1396 S_scalar_slice_warning(pTHX_ const OP *o)
1397 {
1398     OP *kid;
1399     const char lbrack =
1400         o->op_type == OP_HSLICE ? '{' : '[';
1401     const char rbrack =
1402         o->op_type == OP_HSLICE ? '}' : ']';
1403     SV *name;
1404     SV *keysv = NULL; /* just to silence compiler warnings */
1405     const char *key = NULL;
1406
1407     if (!(o->op_private & OPpSLICEWARNING))
1408         return;
1409     if (PL_parser && PL_parser->error_count)
1410         /* This warning can be nonsensical when there is a syntax error. */
1411         return;
1412
1413     kid = cLISTOPo->op_first;
1414     kid = OP_SIBLING(kid); /* get past pushmark */
1415     /* weed out false positives: any ops that can return lists */
1416     switch (kid->op_type) {
1417     case OP_BACKTICK:
1418     case OP_GLOB:
1419     case OP_READLINE:
1420     case OP_MATCH:
1421     case OP_RV2AV:
1422     case OP_EACH:
1423     case OP_VALUES:
1424     case OP_KEYS:
1425     case OP_SPLIT:
1426     case OP_LIST:
1427     case OP_SORT:
1428     case OP_REVERSE:
1429     case OP_ENTERSUB:
1430     case OP_CALLER:
1431     case OP_LSTAT:
1432     case OP_STAT:
1433     case OP_READDIR:
1434     case OP_SYSTEM:
1435     case OP_TMS:
1436     case OP_LOCALTIME:
1437     case OP_GMTIME:
1438     case OP_ENTEREVAL:
1439     case OP_REACH:
1440     case OP_RKEYS:
1441     case OP_RVALUES:
1442         return;
1443     }
1444
1445     /* Don't warn if we have a nulled list either. */
1446     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1447         return;
1448
1449     assert(OP_SIBLING(kid));
1450     name = S_op_varname(aTHX_ OP_SIBLING(kid));
1451     if (!name) /* XS module fiddling with the op tree */
1452         return;
1453     S_op_pretty(aTHX_ kid, &keysv, &key);
1454     assert(SvPOK(name));
1455     sv_chop(name,SvPVX(name)+1);
1456     if (key)
1457        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1458         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1459                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1460                    "%c%s%c",
1461                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1462                     lbrack, key, rbrack);
1463     else
1464        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1465         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1466                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1467                     SVf"%c%"SVf"%c",
1468                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1469                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1470 }
1471
1472 OP *
1473 Perl_scalar(pTHX_ OP *o)
1474 {
1475     OP *kid;
1476
1477     /* assumes no premature commitment */
1478     if (!o || (PL_parser && PL_parser->error_count)
1479          || (o->op_flags & OPf_WANT)
1480          || o->op_type == OP_RETURN)
1481     {
1482         return o;
1483     }
1484
1485     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1486
1487     switch (o->op_type) {
1488     case OP_REPEAT:
1489         scalar(cBINOPo->op_first);
1490         break;
1491     case OP_OR:
1492     case OP_AND:
1493     case OP_COND_EXPR:
1494         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1495             scalar(kid);
1496         break;
1497         /* FALLTHROUGH */
1498     case OP_SPLIT:
1499     case OP_MATCH:
1500     case OP_QR:
1501     case OP_SUBST:
1502     case OP_NULL:
1503     default:
1504         if (o->op_flags & OPf_KIDS) {
1505             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1506                 scalar(kid);
1507         }
1508         break;
1509     case OP_LEAVE:
1510     case OP_LEAVETRY:
1511         kid = cLISTOPo->op_first;
1512         scalar(kid);
1513         kid = OP_SIBLING(kid);
1514     do_kids:
1515         while (kid) {
1516             OP *sib = OP_SIBLING(kid);
1517             if (sib && kid->op_type != OP_LEAVEWHEN)
1518                 scalarvoid(kid);
1519             else
1520                 scalar(kid);
1521             kid = sib;
1522         }
1523         PL_curcop = &PL_compiling;
1524         break;
1525     case OP_SCOPE:
1526     case OP_LINESEQ:
1527     case OP_LIST:
1528         kid = cLISTOPo->op_first;
1529         goto do_kids;
1530     case OP_SORT:
1531         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1532         break;
1533     case OP_KVHSLICE:
1534     case OP_KVASLICE:
1535     {
1536         /* Warn about scalar context */
1537         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1538         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1539         SV *name;
1540         SV *keysv;
1541         const char *key = NULL;
1542
1543         /* This warning can be nonsensical when there is a syntax error. */
1544         if (PL_parser && PL_parser->error_count)
1545             break;
1546
1547         if (!ckWARN(WARN_SYNTAX)) break;
1548
1549         kid = cLISTOPo->op_first;
1550         kid = OP_SIBLING(kid); /* get past pushmark */
1551         assert(OP_SIBLING(kid));
1552         name = S_op_varname(aTHX_ OP_SIBLING(kid));
1553         if (!name) /* XS module fiddling with the op tree */
1554             break;
1555         S_op_pretty(aTHX_ kid, &keysv, &key);
1556         assert(SvPOK(name));
1557         sv_chop(name,SvPVX(name)+1);
1558         if (key)
1559   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1560             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1561                        "%%%"SVf"%c%s%c in scalar context better written "
1562                        "as $%"SVf"%c%s%c",
1563                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1564                         lbrack, key, rbrack);
1565         else
1566   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1567             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1568                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1569                        "written as $%"SVf"%c%"SVf"%c",
1570                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1571                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1572     }
1573     }
1574     return o;
1575 }
1576
1577 OP *
1578 Perl_scalarvoid(pTHX_ OP *o)
1579 {
1580     dVAR;
1581     OP *kid;
1582     SV *useless_sv = NULL;
1583     const char* useless = NULL;
1584     SV* sv;
1585     U8 want;
1586
1587     PERL_ARGS_ASSERT_SCALARVOID;
1588
1589     if (o->op_type == OP_NEXTSTATE
1590         || o->op_type == OP_DBSTATE
1591         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1592                                       || o->op_targ == OP_DBSTATE)))
1593         PL_curcop = (COP*)o;            /* for warning below */
1594
1595     /* assumes no premature commitment */
1596     want = o->op_flags & OPf_WANT;
1597     if ((want && want != OPf_WANT_SCALAR)
1598          || (PL_parser && PL_parser->error_count)
1599          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1600     {
1601         return o;
1602     }
1603
1604     if ((o->op_private & OPpTARGET_MY)
1605         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1606     {
1607         return scalar(o);                       /* As if inside SASSIGN */
1608     }
1609
1610     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1611
1612     switch (o->op_type) {
1613     default:
1614         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1615             break;
1616         /* FALLTHROUGH */
1617     case OP_REPEAT:
1618         if (o->op_flags & OPf_STACKED)
1619             break;
1620         goto func_ops;
1621     case OP_SUBSTR:
1622         if (o->op_private == 4)
1623             break;
1624         /* FALLTHROUGH */
1625     case OP_GVSV:
1626     case OP_WANTARRAY:
1627     case OP_GV:
1628     case OP_SMARTMATCH:
1629     case OP_PADSV:
1630     case OP_PADAV:
1631     case OP_PADHV:
1632     case OP_PADANY:
1633     case OP_AV2ARYLEN:
1634     case OP_REF:
1635     case OP_REFGEN:
1636     case OP_SREFGEN:
1637     case OP_DEFINED:
1638     case OP_HEX:
1639     case OP_OCT:
1640     case OP_LENGTH:
1641     case OP_VEC:
1642     case OP_INDEX:
1643     case OP_RINDEX:
1644     case OP_SPRINTF:
1645     case OP_AELEM:
1646     case OP_AELEMFAST:
1647     case OP_AELEMFAST_LEX:
1648     case OP_ASLICE:
1649     case OP_KVASLICE:
1650     case OP_HELEM:
1651     case OP_HSLICE:
1652     case OP_KVHSLICE:
1653     case OP_UNPACK:
1654     case OP_PACK:
1655     case OP_JOIN:
1656     case OP_LSLICE:
1657     case OP_ANONLIST:
1658     case OP_ANONHASH:
1659     case OP_SORT:
1660     case OP_REVERSE:
1661     case OP_RANGE:
1662     case OP_FLIP:
1663     case OP_FLOP:
1664     case OP_CALLER:
1665     case OP_FILENO:
1666     case OP_EOF:
1667     case OP_TELL:
1668     case OP_GETSOCKNAME:
1669     case OP_GETPEERNAME:
1670     case OP_READLINK:
1671     case OP_TELLDIR:
1672     case OP_GETPPID:
1673     case OP_GETPGRP:
1674     case OP_GETPRIORITY:
1675     case OP_TIME:
1676     case OP_TMS:
1677     case OP_LOCALTIME:
1678     case OP_GMTIME:
1679     case OP_GHBYNAME:
1680     case OP_GHBYADDR:
1681     case OP_GHOSTENT:
1682     case OP_GNBYNAME:
1683     case OP_GNBYADDR:
1684     case OP_GNETENT:
1685     case OP_GPBYNAME:
1686     case OP_GPBYNUMBER:
1687     case OP_GPROTOENT:
1688     case OP_GSBYNAME:
1689     case OP_GSBYPORT:
1690     case OP_GSERVENT:
1691     case OP_GPWNAM:
1692     case OP_GPWUID:
1693     case OP_GGRNAM:
1694     case OP_GGRGID:
1695     case OP_GETLOGIN:
1696     case OP_PROTOTYPE:
1697     case OP_RUNCV:
1698       func_ops:
1699         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1700             /* Otherwise it's "Useless use of grep iterator" */
1701             useless = OP_DESC(o);
1702         break;
1703
1704     case OP_SPLIT:
1705         kid = cLISTOPo->op_first;
1706         if (kid && kid->op_type == OP_PUSHRE
1707 #ifdef USE_ITHREADS
1708                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1709 #else
1710                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1711 #endif
1712             useless = OP_DESC(o);
1713         break;
1714
1715     case OP_NOT:
1716        kid = cUNOPo->op_first;
1717        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1718            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1719                 goto func_ops;
1720        }
1721        useless = "negative pattern binding (!~)";
1722        break;
1723
1724     case OP_SUBST:
1725         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1726             useless = "non-destructive substitution (s///r)";
1727         break;
1728
1729     case OP_TRANSR:
1730         useless = "non-destructive transliteration (tr///r)";
1731         break;
1732
1733     case OP_RV2GV:
1734     case OP_RV2SV:
1735     case OP_RV2AV:
1736     case OP_RV2HV:
1737         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1738                 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1739             useless = "a variable";
1740         break;
1741
1742     case OP_CONST:
1743         sv = cSVOPo_sv;
1744         if (cSVOPo->op_private & OPpCONST_STRICT)
1745             no_bareword_allowed(o);
1746         else {
1747             if (ckWARN(WARN_VOID)) {
1748                 /* don't warn on optimised away booleans, eg 
1749                  * use constant Foo, 5; Foo || print; */
1750                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1751                     useless = NULL;
1752                 /* the constants 0 and 1 are permitted as they are
1753                    conventionally used as dummies in constructs like
1754                         1 while some_condition_with_side_effects;  */
1755                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1756                     useless = NULL;
1757                 else if (SvPOK(sv)) {
1758                     SV * const dsv = newSVpvs("");
1759                     useless_sv
1760                         = Perl_newSVpvf(aTHX_
1761                                         "a constant (%s)",
1762                                         pv_pretty(dsv, SvPVX_const(sv),
1763                                                   SvCUR(sv), 32, NULL, NULL,
1764                                                   PERL_PV_PRETTY_DUMP
1765                                                   | PERL_PV_ESCAPE_NOCLEAR
1766                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1767                     SvREFCNT_dec_NN(dsv);
1768                 }
1769                 else if (SvOK(sv)) {
1770                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1771                 }
1772                 else
1773                     useless = "a constant (undef)";
1774             }
1775         }
1776         op_null(o);             /* don't execute or even remember it */
1777         break;
1778
1779     case OP_POSTINC:
1780         o->op_type = OP_PREINC;         /* pre-increment is faster */
1781         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1782         break;
1783
1784     case OP_POSTDEC:
1785         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1786         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1787         break;
1788
1789     case OP_I_POSTINC:
1790         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1791         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1792         break;
1793
1794     case OP_I_POSTDEC:
1795         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1796         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1797         break;
1798
1799     case OP_SASSIGN: {
1800         OP *rv2gv;
1801         UNOP *refgen, *rv2cv;
1802         LISTOP *exlist;
1803
1804         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1805             break;
1806
1807         rv2gv = ((BINOP *)o)->op_last;
1808         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1809             break;
1810
1811         refgen = (UNOP *)((BINOP *)o)->op_first;
1812
1813         if (!refgen || refgen->op_type != OP_REFGEN)
1814             break;
1815
1816         exlist = (LISTOP *)refgen->op_first;
1817         if (!exlist || exlist->op_type != OP_NULL
1818             || exlist->op_targ != OP_LIST)
1819             break;
1820
1821         if (exlist->op_first->op_type != OP_PUSHMARK)
1822             break;
1823
1824         rv2cv = (UNOP*)exlist->op_last;
1825
1826         if (rv2cv->op_type != OP_RV2CV)
1827             break;
1828
1829         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1830         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1831         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1832
1833         o->op_private |= OPpASSIGN_CV_TO_GV;
1834         rv2gv->op_private |= OPpDONT_INIT_GV;
1835         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1836
1837         break;
1838     }
1839
1840     case OP_AASSIGN: {
1841         inplace_aassign(o);
1842         break;
1843     }
1844
1845     case OP_OR:
1846     case OP_AND:
1847         kid = cLOGOPo->op_first;
1848         if (kid->op_type == OP_NOT
1849             && (kid->op_flags & OPf_KIDS)) {
1850             if (o->op_type == OP_AND) {
1851                 o->op_type = OP_OR;
1852                 o->op_ppaddr = PL_ppaddr[OP_OR];
1853             } else {
1854                 o->op_type = OP_AND;
1855                 o->op_ppaddr = PL_ppaddr[OP_AND];
1856             }
1857             op_null(kid);
1858         }
1859         /* FALLTHROUGH */
1860
1861     case OP_DOR:
1862     case OP_COND_EXPR:
1863     case OP_ENTERGIVEN:
1864     case OP_ENTERWHEN:
1865         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1866             scalarvoid(kid);
1867         break;
1868
1869     case OP_NULL:
1870         if (o->op_flags & OPf_STACKED)
1871             break;
1872         /* FALLTHROUGH */
1873     case OP_NEXTSTATE:
1874     case OP_DBSTATE:
1875     case OP_ENTERTRY:
1876     case OP_ENTER:
1877         if (!(o->op_flags & OPf_KIDS))
1878             break;
1879         /* FALLTHROUGH */
1880     case OP_SCOPE:
1881     case OP_LEAVE:
1882     case OP_LEAVETRY:
1883     case OP_LEAVELOOP:
1884     case OP_LINESEQ:
1885     case OP_LIST:
1886     case OP_LEAVEGIVEN:
1887     case OP_LEAVEWHEN:
1888         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1889             scalarvoid(kid);
1890         break;
1891     case OP_ENTEREVAL:
1892         scalarkids(o);
1893         break;
1894     case OP_SCALAR:
1895         return scalar(o);
1896     }
1897
1898     if (useless_sv) {
1899         /* mortalise it, in case warnings are fatal.  */
1900         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1901                        "Useless use of %"SVf" in void context",
1902                        SVfARG(sv_2mortal(useless_sv)));
1903     }
1904     else if (useless) {
1905        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1906                       "Useless use of %s in void context",
1907                       useless);
1908     }
1909     return o;
1910 }
1911
1912 static OP *
1913 S_listkids(pTHX_ OP *o)
1914 {
1915     if (o && o->op_flags & OPf_KIDS) {
1916         OP *kid;
1917         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1918             list(kid);
1919     }
1920     return o;
1921 }
1922
1923 OP *
1924 Perl_list(pTHX_ OP *o)
1925 {
1926     OP *kid;
1927
1928     /* assumes no premature commitment */
1929     if (!o || (o->op_flags & OPf_WANT)
1930          || (PL_parser && PL_parser->error_count)
1931          || o->op_type == OP_RETURN)
1932     {
1933         return o;
1934     }
1935
1936     if ((o->op_private & OPpTARGET_MY)
1937         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1938     {
1939         return o;                               /* As if inside SASSIGN */
1940     }
1941
1942     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1943
1944     switch (o->op_type) {
1945     case OP_FLOP:
1946     case OP_REPEAT:
1947         list(cBINOPo->op_first);
1948         break;
1949     case OP_OR:
1950     case OP_AND:
1951     case OP_COND_EXPR:
1952         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1953             list(kid);
1954         break;
1955     default:
1956     case OP_MATCH:
1957     case OP_QR:
1958     case OP_SUBST:
1959     case OP_NULL:
1960         if (!(o->op_flags & OPf_KIDS))
1961             break;
1962         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1963             list(cBINOPo->op_first);
1964             return gen_constant_list(o);
1965         }
1966     case OP_LIST:
1967         listkids(o);
1968         break;
1969     case OP_LEAVE:
1970     case OP_LEAVETRY:
1971         kid = cLISTOPo->op_first;
1972         list(kid);
1973         kid = OP_SIBLING(kid);
1974     do_kids:
1975         while (kid) {
1976             OP *sib = OP_SIBLING(kid);
1977             if (sib && kid->op_type != OP_LEAVEWHEN)
1978                 scalarvoid(kid);
1979             else
1980                 list(kid);
1981             kid = sib;
1982         }
1983         PL_curcop = &PL_compiling;
1984         break;
1985     case OP_SCOPE:
1986     case OP_LINESEQ:
1987         kid = cLISTOPo->op_first;
1988         goto do_kids;
1989     }
1990     return o;
1991 }
1992
1993 static OP *
1994 S_scalarseq(pTHX_ OP *o)
1995 {
1996     if (o) {
1997         const OPCODE type = o->op_type;
1998
1999         if (type == OP_LINESEQ || type == OP_SCOPE ||
2000             type == OP_LEAVE || type == OP_LEAVETRY)
2001         {
2002             OP *kid;
2003             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2004                 if (OP_HAS_SIBLING(kid)) {
2005                     scalarvoid(kid);
2006                 }
2007             }
2008             PL_curcop = &PL_compiling;
2009         }
2010         o->op_flags &= ~OPf_PARENS;
2011         if (PL_hints & HINT_BLOCK_SCOPE)
2012             o->op_flags |= OPf_PARENS;
2013     }
2014     else
2015         o = newOP(OP_STUB, 0);
2016     return o;
2017 }
2018
2019 STATIC OP *
2020 S_modkids(pTHX_ OP *o, I32 type)
2021 {
2022     if (o && o->op_flags & OPf_KIDS) {
2023         OP *kid;
2024         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2025             op_lvalue(kid, type);
2026     }
2027     return o;
2028 }
2029
2030 /*
2031 =for apidoc finalize_optree
2032
2033 This function finalizes the optree.  Should be called directly after
2034 the complete optree is built.  It does some additional
2035 checking which can't be done in the normal ck_xxx functions and makes
2036 the tree thread-safe.
2037
2038 =cut
2039 */
2040 void
2041 Perl_finalize_optree(pTHX_ OP* o)
2042 {
2043     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2044
2045     ENTER;
2046     SAVEVPTR(PL_curcop);
2047
2048     finalize_op(o);
2049
2050     LEAVE;
2051 }
2052
2053 STATIC void
2054 S_finalize_op(pTHX_ OP* o)
2055 {
2056     PERL_ARGS_ASSERT_FINALIZE_OP;
2057
2058
2059     switch (o->op_type) {
2060     case OP_NEXTSTATE:
2061     case OP_DBSTATE:
2062         PL_curcop = ((COP*)o);          /* for warnings */
2063         break;
2064     case OP_EXEC:
2065         if (OP_HAS_SIBLING(o)) {
2066             OP *sib = OP_SIBLING(o);
2067             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2068                 && ckWARN(WARN_EXEC)
2069                 && OP_HAS_SIBLING(sib))
2070             {
2071                     const OPCODE type = OP_SIBLING(sib)->op_type;
2072                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2073                         const line_t oldline = CopLINE(PL_curcop);
2074                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2075                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2076                             "Statement unlikely to be reached");
2077                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2078                             "\t(Maybe you meant system() when you said exec()?)\n");
2079                         CopLINE_set(PL_curcop, oldline);
2080                     }
2081             }
2082         }
2083         break;
2084
2085     case OP_GV:
2086         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2087             GV * const gv = cGVOPo_gv;
2088             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2089                 /* XXX could check prototype here instead of just carping */
2090                 SV * const sv = sv_newmortal();
2091                 gv_efullname3(sv, gv, NULL);
2092                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2093                     "%"SVf"() called too early to check prototype",
2094                     SVfARG(sv));
2095             }
2096         }
2097         break;
2098
2099     case OP_CONST:
2100         if (cSVOPo->op_private & OPpCONST_STRICT)
2101             no_bareword_allowed(o);
2102         /* FALLTHROUGH */
2103 #ifdef USE_ITHREADS
2104     case OP_HINTSEVAL:
2105     case OP_METHOD_NAMED:
2106         /* Relocate sv to the pad for thread safety.
2107          * Despite being a "constant", the SV is written to,
2108          * for reference counts, sv_upgrade() etc. */
2109         if (cSVOPo->op_sv) {
2110             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
2111             SvREFCNT_dec(PAD_SVl(ix));
2112             PAD_SETSV(ix, cSVOPo->op_sv);
2113             /* XXX I don't know how this isn't readonly already. */
2114             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2115             cSVOPo->op_sv = NULL;
2116             o->op_targ = ix;
2117         }
2118 #endif
2119         break;
2120
2121     case OP_HELEM: {
2122         UNOP *rop;
2123         SV *lexname;
2124         GV **fields;
2125         SVOP *key_op;
2126         OP *kid;
2127         bool check_fields;
2128
2129         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2130             break;
2131
2132         rop = (UNOP*)((BINOP*)o)->op_first;
2133
2134         goto check_keys;
2135
2136     case OP_HSLICE:
2137         S_scalar_slice_warning(aTHX_ o);
2138         /* FALLTHROUGH */
2139
2140     case OP_KVHSLICE:
2141         kid = OP_SIBLING(cLISTOPo->op_first);
2142         if (/* I bet there's always a pushmark... */
2143             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2144             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2145         {
2146             break;
2147         }
2148
2149         key_op = (SVOP*)(kid->op_type == OP_CONST
2150                                 ? kid
2151                                 : OP_SIBLING(kLISTOP->op_first));
2152
2153         rop = (UNOP*)((LISTOP*)o)->op_last;
2154
2155       check_keys:       
2156         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2157             rop = NULL;
2158         else if (rop->op_first->op_type == OP_PADSV)
2159             /* @$hash{qw(keys here)} */
2160             rop = (UNOP*)rop->op_first;
2161         else {
2162             /* @{$hash}{qw(keys here)} */
2163             if (rop->op_first->op_type == OP_SCOPE
2164                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2165                 {
2166                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2167                 }
2168             else
2169                 rop = NULL;
2170         }
2171
2172         lexname = NULL; /* just to silence compiler warnings */
2173         fields  = NULL; /* just to silence compiler warnings */
2174
2175         check_fields =
2176             rop
2177          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2178              SvPAD_TYPED(lexname))
2179          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2180          && isGV(*fields) && GvHV(*fields);
2181         for (; key_op;
2182              key_op = (SVOP*)OP_SIBLING(key_op)) {
2183             SV **svp, *sv;
2184             if (key_op->op_type != OP_CONST)
2185                 continue;
2186             svp = cSVOPx_svp(key_op);
2187
2188             /* Make the CONST have a shared SV */
2189             if ((!SvIsCOW_shared_hash(sv = *svp))
2190              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2191                 SSize_t keylen;
2192                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2193                 SV *nsv = newSVpvn_share(key,
2194                                          SvUTF8(sv) ? -keylen : keylen, 0);
2195                 SvREFCNT_dec_NN(sv);
2196                 *svp = nsv;
2197             }
2198
2199             if (check_fields
2200              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2201                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
2202                            "in variable %"SVf" of type %"HEKf, 
2203                       SVfARG(*svp), SVfARG(lexname),
2204                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2205             }
2206         }
2207         break;
2208     }
2209     case OP_ASLICE:
2210         S_scalar_slice_warning(aTHX_ o);
2211         break;
2212
2213     case OP_SUBST: {
2214         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2215             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2216         break;
2217     }
2218     default:
2219         break;
2220     }
2221
2222     if (o->op_flags & OPf_KIDS) {
2223         OP *kid;
2224
2225 #ifdef DEBUGGING
2226         /* check that op_last points to the last sibling, and that
2227          * the last op_sibling field points back to the parent, and
2228          * that the only ops with KIDS are those which are entitled to
2229          * them */
2230         U32 type = o->op_type;
2231         U32 family;
2232         bool has_last;
2233
2234         if (type == OP_NULL) {
2235             type = o->op_targ;
2236             /* ck_glob creates a null UNOP with ex-type GLOB
2237              * (which is a list op. So pretend it wasn't a listop */
2238             if (type == OP_GLOB)
2239                 type = OP_NULL;
2240         }
2241         family = PL_opargs[type] & OA_CLASS_MASK;
2242
2243         has_last = (   family == OA_BINOP
2244                     || family == OA_LISTOP
2245                     || family == OA_PMOP
2246                     || family == OA_LOOP
2247                    );
2248         assert(  has_last /* has op_first and op_last, or ...
2249               ... has (or may have) op_first: */
2250               || family == OA_UNOP
2251               || family == OA_LOGOP
2252               || family == OA_BASEOP_OR_UNOP
2253               || family == OA_FILESTATOP
2254               || family == OA_LOOPEXOP
2255               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2256               || type == OP_SASSIGN
2257               || type == OP_CUSTOM
2258               || type == OP_NULL /* new_logop does this */
2259               );
2260         /* XXX list form of 'x' is has a null op_last. This is wrong,
2261          * but requires too much hacking (e.g. in Deparse) to fix for
2262          * now */
2263         if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2264             assert(has_last);
2265             has_last = 0;
2266         }
2267
2268         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2269 #  ifdef PERL_OP_PARENT
2270             if (!OP_HAS_SIBLING(kid)) {
2271                 if (has_last)
2272                     assert(kid == cLISTOPo->op_last);
2273                 assert(kid->op_sibling == o);
2274             }
2275 #  else
2276             if (OP_HAS_SIBLING(kid)) {
2277                 assert(!kid->op_lastsib);
2278             }
2279             else {
2280                 assert(kid->op_lastsib);
2281                 if (has_last)
2282                     assert(kid == cLISTOPo->op_last);
2283             }
2284 #  endif
2285         }
2286 #endif
2287
2288         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2289             finalize_op(kid);
2290     }
2291 }
2292
2293 /*
2294 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2295
2296 Propagate lvalue ("modifiable") context to an op and its children.
2297 I<type> represents the context type, roughly based on the type of op that
2298 would do the modifying, although C<local()> is represented by OP_NULL,
2299 because it has no op type of its own (it is signalled by a flag on
2300 the lvalue op).
2301
2302 This function detects things that can't be modified, such as C<$x+1>, and
2303 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2304 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2305
2306 It also flags things that need to behave specially in an lvalue context,
2307 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2308
2309 =cut
2310 */
2311
2312 static bool
2313 S_vivifies(const OPCODE type)
2314 {
2315     switch(type) {
2316     case OP_RV2AV:     case   OP_ASLICE:
2317     case OP_RV2HV:     case OP_KVASLICE:
2318     case OP_RV2SV:     case   OP_HSLICE:
2319     case OP_AELEMFAST: case OP_KVHSLICE:
2320     case OP_HELEM:
2321     case OP_AELEM:
2322         return 1;
2323     }
2324     return 0;
2325 }
2326
2327 OP *
2328 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2329 {
2330     dVAR;
2331     OP *kid;
2332     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2333     int localize = -1;
2334
2335     if (!o || (PL_parser && PL_parser->error_count))
2336         return o;
2337
2338     if ((o->op_private & OPpTARGET_MY)
2339         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2340     {
2341         return o;
2342     }
2343
2344     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2345
2346     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2347
2348     switch (o->op_type) {
2349     case OP_UNDEF:
2350         PL_modcount++;
2351         return o;
2352     case OP_STUB:
2353         if ((o->op_flags & OPf_PARENS))
2354             break;
2355         goto nomod;
2356     case OP_ENTERSUB:
2357         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2358             !(o->op_flags & OPf_STACKED)) {
2359             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2360             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2361             assert(cUNOPo->op_first->op_type == OP_NULL);
2362             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2363             break;
2364         }
2365         else {                          /* lvalue subroutine call */
2366             o->op_private |= OPpLVAL_INTRO
2367                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2368             PL_modcount = RETURN_UNLIMITED_NUMBER;
2369             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2370                 /* Potential lvalue context: */
2371                 o->op_private |= OPpENTERSUB_INARGS;
2372                 break;
2373             }
2374             else {                      /* Compile-time error message: */
2375                 OP *kid = cUNOPo->op_first;
2376                 CV *cv;
2377                 GV *gv;
2378
2379                 if (kid->op_type != OP_PUSHMARK) {
2380                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2381                         Perl_croak(aTHX_
2382                                 "panic: unexpected lvalue entersub "
2383                                 "args: type/targ %ld:%"UVuf,
2384                                 (long)kid->op_type, (UV)kid->op_targ);
2385                     kid = kLISTOP->op_first;
2386                 }
2387                 while (OP_HAS_SIBLING(kid))
2388                     kid = OP_SIBLING(kid);
2389                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2390                     break;      /* Postpone until runtime */
2391                 }
2392
2393                 kid = kUNOP->op_first;
2394                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2395                     kid = kUNOP->op_first;
2396                 if (kid->op_type == OP_NULL)
2397                     Perl_croak(aTHX_
2398                                "Unexpected constant lvalue entersub "
2399                                "entry via type/targ %ld:%"UVuf,
2400                                (long)kid->op_type, (UV)kid->op_targ);
2401                 if (kid->op_type != OP_GV) {
2402                     break;
2403                 }
2404
2405                 gv = kGVOP_gv;
2406                 cv = isGV(gv)
2407                     ? GvCV(gv)
2408                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2409                         ? MUTABLE_CV(SvRV(gv))
2410                         : NULL;
2411                 if (!cv)
2412                     break;
2413                 if (CvLVALUE(cv))
2414                     break;
2415             }
2416         }
2417         /* FALLTHROUGH */
2418     default:
2419       nomod:
2420         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2421         /* grep, foreach, subcalls, refgen */
2422         if (type == OP_GREPSTART || type == OP_ENTERSUB
2423          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2424             break;
2425         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2426                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2427                       ? "do block"
2428                       : (o->op_type == OP_ENTERSUB
2429                         ? "non-lvalue subroutine call"
2430                         : OP_DESC(o))),
2431                      type ? PL_op_desc[type] : "local"));
2432         return o;
2433
2434     case OP_PREINC:
2435     case OP_PREDEC:
2436     case OP_POW:
2437     case OP_MULTIPLY:
2438     case OP_DIVIDE:
2439     case OP_MODULO:
2440     case OP_REPEAT:
2441     case OP_ADD:
2442     case OP_SUBTRACT:
2443     case OP_CONCAT:
2444     case OP_LEFT_SHIFT:
2445     case OP_RIGHT_SHIFT:
2446     case OP_BIT_AND:
2447     case OP_BIT_XOR:
2448     case OP_BIT_OR:
2449     case OP_I_MULTIPLY:
2450     case OP_I_DIVIDE:
2451     case OP_I_MODULO:
2452     case OP_I_ADD:
2453     case OP_I_SUBTRACT:
2454         if (!(o->op_flags & OPf_STACKED))
2455             goto nomod;
2456         PL_modcount++;
2457         break;
2458
2459     case OP_COND_EXPR:
2460         localize = 1;
2461         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2462             op_lvalue(kid, type);
2463         break;
2464
2465     case OP_RV2AV:
2466     case OP_RV2HV:
2467         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2468            PL_modcount = RETURN_UNLIMITED_NUMBER;
2469             return o;           /* Treat \(@foo) like ordinary list. */
2470         }
2471         /* FALLTHROUGH */
2472     case OP_RV2GV:
2473         if (scalar_mod_type(o, type))
2474             goto nomod;
2475         ref(cUNOPo->op_first, o->op_type);
2476         /* FALLTHROUGH */
2477     case OP_ASLICE:
2478     case OP_HSLICE:
2479         localize = 1;
2480         /* FALLTHROUGH */
2481     case OP_AASSIGN:
2482         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2483         if (type == OP_LEAVESUBLV && (
2484                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2485              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2486            ))
2487             o->op_private |= OPpMAYBE_LVSUB;
2488         /* FALLTHROUGH */
2489     case OP_NEXTSTATE:
2490     case OP_DBSTATE:
2491        PL_modcount = RETURN_UNLIMITED_NUMBER;
2492         break;
2493     case OP_KVHSLICE:
2494     case OP_KVASLICE:
2495         if (type == OP_LEAVESUBLV)
2496             o->op_private |= OPpMAYBE_LVSUB;
2497         goto nomod;
2498     case OP_AV2ARYLEN:
2499         PL_hints |= HINT_BLOCK_SCOPE;
2500         if (type == OP_LEAVESUBLV)
2501             o->op_private |= OPpMAYBE_LVSUB;
2502         PL_modcount++;
2503         break;
2504     case OP_RV2SV:
2505         ref(cUNOPo->op_first, o->op_type);
2506         localize = 1;
2507         /* FALLTHROUGH */
2508     case OP_GV:
2509         PL_hints |= HINT_BLOCK_SCOPE;
2510         /* FALLTHROUGH */
2511     case OP_SASSIGN:
2512     case OP_ANDASSIGN:
2513     case OP_ORASSIGN:
2514     case OP_DORASSIGN:
2515         PL_modcount++;
2516         break;
2517
2518     case OP_AELEMFAST:
2519     case OP_AELEMFAST_LEX:
2520         localize = -1;
2521         PL_modcount++;
2522         break;
2523
2524     case OP_PADAV:
2525     case OP_PADHV:
2526        PL_modcount = RETURN_UNLIMITED_NUMBER;
2527         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2528             return o;           /* Treat \(@foo) like ordinary list. */
2529         if (scalar_mod_type(o, type))
2530             goto nomod;
2531         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2532           && type == OP_LEAVESUBLV)
2533             o->op_private |= OPpMAYBE_LVSUB;
2534         /* FALLTHROUGH */
2535     case OP_PADSV:
2536         PL_modcount++;
2537         if (!type) /* local() */
2538             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2539                  PAD_COMPNAME_SV(o->op_targ));
2540         break;
2541
2542     case OP_PUSHMARK:
2543         localize = 0;
2544         break;
2545
2546     case OP_KEYS:
2547     case OP_RKEYS:
2548         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2549             goto nomod;
2550         goto lvalue_func;
2551     case OP_SUBSTR:
2552         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2553             goto nomod;
2554         /* FALLTHROUGH */
2555     case OP_POS:
2556     case OP_VEC:
2557       lvalue_func:
2558         if (type == OP_LEAVESUBLV)
2559             o->op_private |= OPpMAYBE_LVSUB;
2560         if (o->op_flags & OPf_KIDS)
2561             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2562         break;
2563
2564     case OP_AELEM:
2565     case OP_HELEM:
2566         ref(cBINOPo->op_first, o->op_type);
2567         if (type == OP_ENTERSUB &&
2568              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2569             o->op_private |= OPpLVAL_DEFER;
2570         if (type == OP_LEAVESUBLV)
2571             o->op_private |= OPpMAYBE_LVSUB;
2572         localize = 1;
2573         PL_modcount++;
2574         break;
2575
2576     case OP_LEAVE:
2577     case OP_LEAVELOOP:
2578         o->op_private |= OPpLVALUE;
2579         /* FALLTHROUGH */
2580     case OP_SCOPE:
2581     case OP_ENTER:
2582     case OP_LINESEQ:
2583         localize = 0;
2584         if (o->op_flags & OPf_KIDS)
2585             op_lvalue(cLISTOPo->op_last, type);
2586         break;
2587
2588     case OP_NULL:
2589         localize = 0;
2590         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2591             goto nomod;
2592         else if (!(o->op_flags & OPf_KIDS))
2593             break;
2594         if (o->op_targ != OP_LIST) {
2595             op_lvalue(cBINOPo->op_first, type);
2596             break;
2597         }
2598         /* FALLTHROUGH */
2599     case OP_LIST:
2600         localize = 0;
2601         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2602             /* elements might be in void context because the list is
2603                in scalar context or because they are attribute sub calls */
2604             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2605                 op_lvalue(kid, type);
2606         break;
2607
2608     case OP_RETURN:
2609         if (type != OP_LEAVESUBLV)
2610             goto nomod;
2611         break; /* op_lvalue()ing was handled by ck_return() */
2612
2613     case OP_COREARGS:
2614         return o;
2615
2616     case OP_AND:
2617     case OP_OR:
2618         if (type == OP_LEAVESUBLV
2619          || !S_vivifies(cLOGOPo->op_first->op_type))
2620             op_lvalue(cLOGOPo->op_first, type);
2621         if (type == OP_LEAVESUBLV
2622          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2623             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2624         goto nomod;
2625     }
2626
2627     /* [20011101.069] File test operators interpret OPf_REF to mean that
2628        their argument is a filehandle; thus \stat(".") should not set
2629        it. AMS 20011102 */
2630     if (type == OP_REFGEN &&
2631         PL_check[o->op_type] == Perl_ck_ftst)
2632         return o;
2633
2634     if (type != OP_LEAVESUBLV)
2635         o->op_flags |= OPf_MOD;
2636
2637     if (type == OP_AASSIGN || type == OP_SASSIGN)
2638         o->op_flags |= OPf_SPECIAL|OPf_REF;
2639     else if (!type) { /* local() */
2640         switch (localize) {
2641         case 1:
2642             o->op_private |= OPpLVAL_INTRO;
2643             o->op_flags &= ~OPf_SPECIAL;
2644             PL_hints |= HINT_BLOCK_SCOPE;
2645             break;
2646         case 0:
2647             break;
2648         case -1:
2649             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2650                            "Useless localization of %s", OP_DESC(o));
2651         }
2652     }
2653     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2654              && type != OP_LEAVESUBLV)
2655         o->op_flags |= OPf_REF;
2656     return o;
2657 }
2658
2659 STATIC bool
2660 S_scalar_mod_type(const OP *o, I32 type)
2661 {
2662     switch (type) {
2663     case OP_POS:
2664     case OP_SASSIGN:
2665         if (o && o->op_type == OP_RV2GV)
2666             return FALSE;
2667         /* FALLTHROUGH */
2668     case OP_PREINC:
2669     case OP_PREDEC:
2670     case OP_POSTINC:
2671     case OP_POSTDEC:
2672     case OP_I_PREINC:
2673     case OP_I_PREDEC:
2674     case OP_I_POSTINC:
2675     case OP_I_POSTDEC:
2676     case OP_POW:
2677     case OP_MULTIPLY:
2678     case OP_DIVIDE:
2679     case OP_MODULO:
2680     case OP_REPEAT:
2681     case OP_ADD:
2682     case OP_SUBTRACT:
2683     case OP_I_MULTIPLY:
2684     case OP_I_DIVIDE:
2685     case OP_I_MODULO:
2686     case OP_I_ADD:
2687     case OP_I_SUBTRACT:
2688     case OP_LEFT_SHIFT:
2689     case OP_RIGHT_SHIFT:
2690     case OP_BIT_AND:
2691     case OP_BIT_XOR:
2692     case OP_BIT_OR:
2693     case OP_CONCAT:
2694     case OP_SUBST:
2695     case OP_TRANS:
2696     case OP_TRANSR:
2697     case OP_READ:
2698     case OP_SYSREAD:
2699     case OP_RECV:
2700     case OP_ANDASSIGN:
2701     case OP_ORASSIGN:
2702     case OP_DORASSIGN:
2703         return TRUE;
2704     default:
2705         return FALSE;
2706     }
2707 }
2708
2709 STATIC bool
2710 S_is_handle_constructor(const OP *o, I32 numargs)
2711 {
2712     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2713
2714     switch (o->op_type) {
2715     case OP_PIPE_OP:
2716     case OP_SOCKPAIR:
2717         if (numargs == 2)
2718             return TRUE;
2719         /* FALLTHROUGH */
2720     case OP_SYSOPEN:
2721     case OP_OPEN:
2722     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2723     case OP_SOCKET:
2724     case OP_OPEN_DIR:
2725     case OP_ACCEPT:
2726         if (numargs == 1)
2727             return TRUE;
2728         /* FALLTHROUGH */
2729     default:
2730         return FALSE;
2731     }
2732 }
2733
2734 static OP *
2735 S_refkids(pTHX_ OP *o, I32 type)
2736 {
2737     if (o && o->op_flags & OPf_KIDS) {
2738         OP *kid;
2739         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2740             ref(kid, type);
2741     }
2742     return o;
2743 }
2744
2745 OP *
2746 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2747 {
2748     dVAR;
2749     OP *kid;
2750
2751     PERL_ARGS_ASSERT_DOREF;
2752
2753     if (!o || (PL_parser && PL_parser->error_count))
2754         return o;
2755
2756     switch (o->op_type) {
2757     case OP_ENTERSUB:
2758         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2759             !(o->op_flags & OPf_STACKED)) {
2760             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2761             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2762             assert(cUNOPo->op_first->op_type == OP_NULL);
2763             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2764             o->op_flags |= OPf_SPECIAL;
2765         }
2766         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2767             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2768                               : type == OP_RV2HV ? OPpDEREF_HV
2769                               : OPpDEREF_SV);
2770             o->op_flags |= OPf_MOD;
2771         }
2772
2773         break;
2774
2775     case OP_COND_EXPR:
2776         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2777             doref(kid, type, set_op_ref);
2778         break;
2779     case OP_RV2SV:
2780         if (type == OP_DEFINED)
2781             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2782         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2783         /* FALLTHROUGH */
2784     case OP_PADSV:
2785         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2786             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2787                               : type == OP_RV2HV ? OPpDEREF_HV
2788                               : OPpDEREF_SV);
2789             o->op_flags |= OPf_MOD;
2790         }
2791         break;
2792
2793     case OP_RV2AV:
2794     case OP_RV2HV:
2795         if (set_op_ref)
2796             o->op_flags |= OPf_REF;
2797         /* FALLTHROUGH */
2798     case OP_RV2GV:
2799         if (type == OP_DEFINED)
2800             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2801         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2802         break;
2803
2804     case OP_PADAV:
2805     case OP_PADHV:
2806         if (set_op_ref)
2807             o->op_flags |= OPf_REF;
2808         break;
2809
2810     case OP_SCALAR:
2811     case OP_NULL:
2812         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2813             break;
2814         doref(cBINOPo->op_first, type, set_op_ref);
2815         break;
2816     case OP_AELEM:
2817     case OP_HELEM:
2818         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2819         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2820             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2821                               : type == OP_RV2HV ? OPpDEREF_HV
2822                               : OPpDEREF_SV);
2823             o->op_flags |= OPf_MOD;
2824         }
2825         break;
2826
2827     case OP_SCOPE:
2828     case OP_LEAVE:
2829         set_op_ref = FALSE;
2830         /* FALLTHROUGH */
2831     case OP_ENTER:
2832     case OP_LIST:
2833         if (!(o->op_flags & OPf_KIDS))
2834             break;
2835         doref(cLISTOPo->op_last, type, set_op_ref);
2836         break;
2837     default:
2838         break;
2839     }
2840     return scalar(o);
2841
2842 }
2843
2844 STATIC OP *
2845 S_dup_attrlist(pTHX_ OP *o)
2846 {
2847     OP *rop;
2848
2849     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2850
2851     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2852      * where the first kid is OP_PUSHMARK and the remaining ones
2853      * are OP_CONST.  We need to push the OP_CONST values.
2854      */
2855     if (o->op_type == OP_CONST)
2856         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2857     else {
2858         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2859         rop = NULL;
2860         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2861             if (o->op_type == OP_CONST)
2862                 rop = op_append_elem(OP_LIST, rop,
2863                                   newSVOP(OP_CONST, o->op_flags,
2864                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2865         }
2866     }
2867     return rop;
2868 }
2869
2870 STATIC void
2871 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2872 {
2873     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2874
2875     PERL_ARGS_ASSERT_APPLY_ATTRS;
2876
2877     /* fake up C<use attributes $pkg,$rv,@attrs> */
2878
2879 #define ATTRSMODULE "attributes"
2880 #define ATTRSMODULE_PM "attributes.pm"
2881
2882     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2883                          newSVpvs(ATTRSMODULE),
2884                          NULL,
2885                          op_prepend_elem(OP_LIST,
2886                                       newSVOP(OP_CONST, 0, stashsv),
2887                                       op_prepend_elem(OP_LIST,
2888                                                    newSVOP(OP_CONST, 0,
2889                                                            newRV(target)),
2890                                                    dup_attrlist(attrs))));
2891 }
2892
2893 STATIC void
2894 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2895 {
2896     OP *pack, *imop, *arg;
2897     SV *meth, *stashsv, **svp;
2898
2899     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2900
2901     if (!attrs)
2902         return;
2903
2904     assert(target->op_type == OP_PADSV ||
2905            target->op_type == OP_PADHV ||
2906            target->op_type == OP_PADAV);
2907
2908     /* Ensure that attributes.pm is loaded. */
2909     /* Don't force the C<use> if we don't need it. */
2910     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2911     if (svp && *svp != &PL_sv_undef)
2912         NOOP;   /* already in %INC */
2913     else
2914         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2915                                newSVpvs(ATTRSMODULE), NULL);
2916
2917     /* Need package name for method call. */
2918     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2919
2920     /* Build up the real arg-list. */
2921     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2922
2923     arg = newOP(OP_PADSV, 0);
2924     arg->op_targ = target->op_targ;
2925     arg = op_prepend_elem(OP_LIST,
2926                        newSVOP(OP_CONST, 0, stashsv),
2927                        op_prepend_elem(OP_LIST,
2928                                     newUNOP(OP_REFGEN, 0,
2929                                             op_lvalue(arg, OP_REFGEN)),
2930                                     dup_attrlist(attrs)));
2931
2932     /* Fake up a method call to import */
2933     meth = newSVpvs_share("import");
2934     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2935                    op_append_elem(OP_LIST,
2936                                op_prepend_elem(OP_LIST, pack, list(arg)),
2937                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2938
2939     /* Combine the ops. */
2940     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2941 }
2942
2943 /*
2944 =notfor apidoc apply_attrs_string
2945
2946 Attempts to apply a list of attributes specified by the C<attrstr> and
2947 C<len> arguments to the subroutine identified by the C<cv> argument which
2948 is expected to be associated with the package identified by the C<stashpv>
2949 argument (see L<attributes>).  It gets this wrong, though, in that it
2950 does not correctly identify the boundaries of the individual attribute
2951 specifications within C<attrstr>.  This is not really intended for the
2952 public API, but has to be listed here for systems such as AIX which
2953 need an explicit export list for symbols.  (It's called from XS code
2954 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2955 to respect attribute syntax properly would be welcome.
2956
2957 =cut
2958 */
2959
2960 void
2961 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2962                         const char *attrstr, STRLEN len)
2963 {
2964     OP *attrs = NULL;
2965
2966     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2967
2968     if (!len) {
2969         len = strlen(attrstr);
2970     }
2971
2972     while (len) {
2973         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2974         if (len) {
2975             const char * const sstr = attrstr;
2976             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2977             attrs = op_append_elem(OP_LIST, attrs,
2978                                 newSVOP(OP_CONST, 0,
2979                                         newSVpvn(sstr, attrstr-sstr)));
2980         }
2981     }
2982
2983     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2984                      newSVpvs(ATTRSMODULE),
2985                      NULL, op_prepend_elem(OP_LIST,
2986                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2987                                   op_prepend_elem(OP_LIST,
2988                                                newSVOP(OP_CONST, 0,
2989                                                        newRV(MUTABLE_SV(cv))),
2990                                                attrs)));
2991 }
2992
2993 STATIC void
2994 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2995 {
2996     OP *new_proto = NULL;
2997     STRLEN pvlen;
2998     char *pv;
2999     OP *o;
3000
3001     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3002
3003     if (!*attrs)
3004         return;
3005
3006     o = *attrs;
3007     if (o->op_type == OP_CONST) {
3008         pv = SvPV(cSVOPo_sv, pvlen);
3009         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3010             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3011             SV ** const tmpo = cSVOPx_svp(o);
3012             SvREFCNT_dec(cSVOPo_sv);
3013             *tmpo = tmpsv;
3014             new_proto = o;
3015             *attrs = NULL;
3016         }
3017     } else if (o->op_type == OP_LIST) {
3018         OP * lasto;
3019         assert(o->op_flags & OPf_KIDS);
3020         lasto = cLISTOPo->op_first;
3021         assert(lasto->op_type == OP_PUSHMARK);
3022         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3023             if (o->op_type == OP_CONST) {
3024                 pv = SvPV(cSVOPo_sv, pvlen);
3025                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3026                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3027                     SV ** const tmpo = cSVOPx_svp(o);
3028                     SvREFCNT_dec(cSVOPo_sv);
3029                     *tmpo = tmpsv;
3030                     if (new_proto && ckWARN(WARN_MISC)) {
3031                         STRLEN new_len;
3032                         const char * newp = SvPV(cSVOPo_sv, new_len);
3033                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3034                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3035                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3036                         op_free(new_proto);
3037                     }
3038                     else if (new_proto)
3039                         op_free(new_proto);
3040                     new_proto = o;
3041                     /* excise new_proto from the list */
3042                     op_sibling_splice(*attrs, lasto, 1, NULL);
3043                     o = lasto;
3044                     continue;
3045                 }
3046             }
3047             lasto = o;
3048         }
3049         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3050            would get pulled in with no real need */
3051         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3052             op_free(*attrs);
3053             *attrs = NULL;
3054         }
3055     }
3056
3057     if (new_proto) {
3058         SV *svname;
3059         if (isGV(name)) {
3060             svname = sv_newmortal();
3061             gv_efullname3(svname, name, NULL);
3062         }
3063         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3064             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3065         else
3066             svname = (SV *)name;
3067         if (ckWARN(WARN_ILLEGALPROTO))
3068             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3069         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3070             STRLEN old_len, new_len;
3071             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3072             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3073
3074             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3075                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3076                 " in %"SVf,
3077                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3078                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3079                 SVfARG(svname));
3080         }
3081         if (*proto)
3082             op_free(*proto);
3083         *proto = new_proto;
3084     }
3085 }
3086
3087 static void
3088 S_cant_declare(pTHX_ OP *o)
3089 {
3090     if (o->op_type == OP_NULL
3091      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3092         o = cUNOPo->op_first;
3093     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3094                              o->op_type == OP_NULL
3095                                && o->op_flags & OPf_SPECIAL
3096                                  ? "do block"
3097                                  : OP_DESC(o),
3098                              PL_parser->in_my == KEY_our   ? "our"   :
3099                              PL_parser->in_my == KEY_state ? "state" :
3100                                                              "my"));
3101 }
3102
3103 STATIC OP *
3104 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3105 {
3106     I32 type;
3107     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3108
3109     PERL_ARGS_ASSERT_MY_KID;
3110
3111     if (!o || (PL_parser && PL_parser->error_count))
3112         return o;
3113
3114     type = o->op_type;
3115
3116     if (type == OP_LIST) {
3117         OP *kid;
3118         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3119             my_kid(kid, attrs, imopsp);
3120         return o;
3121     } else if (type == OP_UNDEF || type == OP_STUB) {
3122         return o;
3123     } else if (type == OP_RV2SV ||      /* "our" declaration */
3124                type == OP_RV2AV ||
3125                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3126         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3127             S_cant_declare(aTHX_ o);
3128         } else if (attrs) {
3129             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3130             assert(PL_parser);
3131             PL_parser->in_my = FALSE;
3132             PL_parser->in_my_stash = NULL;
3133             apply_attrs(GvSTASH(gv),
3134                         (type == OP_RV2SV ? GvSV(gv) :
3135                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3136                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3137                         attrs);
3138         }
3139         o->op_private |= OPpOUR_INTRO;
3140         return o;
3141     }
3142     else if (type != OP_PADSV &&
3143              type != OP_PADAV &&
3144              type != OP_PADHV &&
3145              type != OP_PUSHMARK)
3146     {
3147         S_cant_declare(aTHX_ o);
3148         return o;
3149     }
3150     else if (attrs && type != OP_PUSHMARK) {
3151         HV *stash;
3152
3153         assert(PL_parser);
3154         PL_parser->in_my = FALSE;
3155         PL_parser->in_my_stash = NULL;
3156
3157         /* check for C<my Dog $spot> when deciding package */
3158         stash = PAD_COMPNAME_TYPE(o->op_targ);
3159         if (!stash)
3160             stash = PL_curstash;
3161         apply_attrs_my(stash, o, attrs, imopsp);
3162     }
3163     o->op_flags |= OPf_MOD;
3164     o->op_private |= OPpLVAL_INTRO;
3165     if (stately)
3166         o->op_private |= OPpPAD_STATE;
3167     return o;
3168 }
3169
3170 OP *
3171 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3172 {
3173     OP *rops;
3174     int maybe_scalar = 0;
3175
3176     PERL_ARGS_ASSERT_MY_ATTRS;
3177
3178 /* [perl #17376]: this appears to be premature, and results in code such as
3179    C< our(%x); > executing in list mode rather than void mode */
3180 #if 0
3181     if (o->op_flags & OPf_PARENS)
3182         list(o);
3183     else
3184         maybe_scalar = 1;
3185 #else
3186     maybe_scalar = 1;
3187 #endif
3188     if (attrs)
3189         SAVEFREEOP(attrs);
3190     rops = NULL;
3191     o = my_kid(o, attrs, &rops);
3192     if (rops) {
3193         if (maybe_scalar && o->op_type == OP_PADSV) {
3194             o = scalar(op_append_list(OP_LIST, rops, o));
3195             o->op_private |= OPpLVAL_INTRO;
3196         }
3197         else {
3198             /* The listop in rops might have a pushmark at the beginning,
3199                which will mess up list assignment. */
3200             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3201             if (rops->op_type == OP_LIST && 
3202                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3203             {
3204                 OP * const pushmark = lrops->op_first;
3205                 /* excise pushmark */
3206                 op_sibling_splice(rops, NULL, 1, NULL);
3207                 op_free(pushmark);
3208             }
3209             o = op_append_list(OP_LIST, o, rops);
3210         }
3211     }
3212     PL_parser->in_my = FALSE;
3213     PL_parser->in_my_stash = NULL;
3214     return o;
3215 }
3216
3217 OP *
3218 Perl_sawparens(pTHX_ OP *o)
3219 {
3220     PERL_UNUSED_CONTEXT;
3221     if (o)
3222         o->op_flags |= OPf_PARENS;
3223     return o;
3224 }
3225
3226 OP *
3227 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3228 {
3229     OP *o;
3230     bool ismatchop = 0;
3231     const OPCODE ltype = left->op_type;
3232     const OPCODE rtype = right->op_type;
3233
3234     PERL_ARGS_ASSERT_BIND_MATCH;
3235
3236     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3237           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3238     {
3239       const char * const desc
3240           = PL_op_desc[(
3241                           rtype == OP_SUBST || rtype == OP_TRANS
3242                        || rtype == OP_TRANSR
3243                        )
3244                        ? (int)rtype : OP_MATCH];
3245       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3246       SV * const name =
3247         S_op_varname(aTHX_ left);
3248       if (name)
3249         Perl_warner(aTHX_ packWARN(WARN_MISC),
3250              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3251              desc, SVfARG(name), SVfARG(name));
3252       else {
3253         const char * const sample = (isary
3254              ? "@array" : "%hash");
3255         Perl_warner(aTHX_ packWARN(WARN_MISC),
3256              "Applying %s to %s will act on scalar(%s)",
3257              desc, sample, sample);
3258       }
3259     }
3260
3261     if (rtype == OP_CONST &&
3262         cSVOPx(right)->op_private & OPpCONST_BARE &&
3263         cSVOPx(right)->op_private & OPpCONST_STRICT)
3264     {
3265         no_bareword_allowed(right);
3266     }
3267
3268     /* !~ doesn't make sense with /r, so error on it for now */
3269     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3270         type == OP_NOT)
3271         /* diag_listed_as: Using !~ with %s doesn't make sense */
3272         yyerror("Using !~ with s///r doesn't make sense");
3273     if (rtype == OP_TRANSR && type == OP_NOT)
3274         /* diag_listed_as: Using !~ with %s doesn't make sense */
3275         yyerror("Using !~ with tr///r doesn't make sense");
3276
3277     ismatchop = (rtype == OP_MATCH ||
3278                  rtype == OP_SUBST ||
3279                  rtype == OP_TRANS || rtype == OP_TRANSR)
3280              && !(right->op_flags & OPf_SPECIAL);
3281     if (ismatchop && right->op_private & OPpTARGET_MY) {
3282         right->op_targ = 0;
3283         right->op_private &= ~OPpTARGET_MY;
3284     }
3285     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3286         OP *newleft;
3287
3288         right->op_flags |= OPf_STACKED;
3289         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3290             ! (rtype == OP_TRANS &&
3291                right->op_private & OPpTRANS_IDENTICAL) &&
3292             ! (rtype == OP_SUBST &&
3293                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3294             newleft = op_lvalue(left, rtype);
3295         else
3296             newleft = left;
3297         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3298             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3299         else
3300             o = op_prepend_elem(rtype, scalar(newleft), right);
3301         if (type == OP_NOT)
3302             return newUNOP(OP_NOT, 0, scalar(o));
3303         return o;
3304     }
3305     else
3306         return bind_match(type, left,
3307                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3308 }
3309
3310 OP *
3311 Perl_invert(pTHX_ OP *o)
3312 {
3313     if (!o)
3314         return NULL;
3315     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3316 }
3317
3318 /*
3319 =for apidoc Amx|OP *|op_scope|OP *o
3320
3321 Wraps up an op tree with some additional ops so that at runtime a dynamic
3322 scope will be created.  The original ops run in the new dynamic scope,
3323 and then, provided that they exit normally, the scope will be unwound.
3324 The additional ops used to create and unwind the dynamic scope will
3325 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3326 instead if the ops are simple enough to not need the full dynamic scope
3327 structure.
3328
3329 =cut
3330 */
3331
3332 OP *
3333 Perl_op_scope(pTHX_ OP *o)
3334 {
3335     dVAR;
3336     if (o) {
3337         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3338             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3339             o->op_type = OP_LEAVE;
3340             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3341         }
3342         else if (o->op_type == OP_LINESEQ) {
3343             OP *kid;
3344             o->op_type = OP_SCOPE;
3345             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3346             kid = ((LISTOP*)o)->op_first;
3347             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3348                 op_null(kid);
3349
3350                 /* The following deals with things like 'do {1 for 1}' */
3351                 kid = OP_SIBLING(kid);
3352                 if (kid &&
3353                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3354                     op_null(kid);
3355             }
3356         }
3357         else
3358             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3359     }
3360     return o;
3361 }
3362
3363 OP *
3364 Perl_op_unscope(pTHX_ OP *o)
3365 {
3366     if (o && o->op_type == OP_LINESEQ) {
3367         OP *kid = cLISTOPo->op_first;
3368         for(; kid; kid = OP_SIBLING(kid))
3369             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3370                 op_null(kid);
3371     }
3372     return o;
3373 }
3374
3375 int
3376 Perl_block_start(pTHX_ int full)
3377 {
3378     const int retval = PL_savestack_ix;
3379
3380     pad_block_start(full);
3381     SAVEHINTS();
3382     PL_hints &= ~HINT_BLOCK_SCOPE;
3383     SAVECOMPILEWARNINGS();
3384     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3385
3386     CALL_BLOCK_HOOKS(bhk_start, full);
3387
3388     return retval;
3389 }
3390
3391 OP*
3392 Perl_block_end(pTHX_ I32 floor, OP *seq)
3393 {
3394     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3395     OP* retval = scalarseq(seq);
3396     OP *o;
3397
3398     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3399
3400     LEAVE_SCOPE(floor);
3401     if (needblockscope)
3402         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3403     o = pad_leavemy();
3404
3405     if (o) {
3406         /* pad_leavemy has created a sequence of introcv ops for all my
3407            subs declared in the block.  We have to replicate that list with
3408            clonecv ops, to deal with this situation:
3409
3410                sub {
3411                    my sub s1;
3412                    my sub s2;
3413                    sub s1 { state sub foo { \&s2 } }
3414                }->()
3415
3416            Originally, I was going to have introcv clone the CV and turn
3417            off the stale flag.  Since &s1 is declared before &s2, the
3418            introcv op for &s1 is executed (on sub entry) before the one for
3419            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3420            cloned, since it is a state sub) closes over &s2 and expects
3421            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3422            then &s2 is still marked stale.  Since &s1 is not active, and
3423            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3424            ble will not stay shared’ warning.  Because it is the same stub
3425            that will be used when the introcv op for &s2 is executed, clos-
3426            ing over it is safe.  Hence, we have to turn off the stale flag
3427            on all lexical subs in the block before we clone any of them.
3428            Hence, having introcv clone the sub cannot work.  So we create a
3429            list of ops like this:
3430
3431                lineseq
3432                   |
3433                   +-- introcv
3434                   |
3435                   +-- introcv
3436                   |
3437                   +-- introcv
3438                   |
3439                   .
3440                   .
3441                   .
3442                   |
3443                   +-- clonecv
3444                   |
3445                   +-- clonecv
3446                   |
3447                   +-- clonecv
3448                   |
3449                   .
3450                   .
3451                   .
3452          */
3453         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3454         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3455         for (;; kid = OP_SIBLING(kid)) {
3456             OP *newkid = newOP(OP_CLONECV, 0);
3457             newkid->op_targ = kid->op_targ;
3458             o = op_append_elem(OP_LINESEQ, o, newkid);
3459             if (kid == last) break;
3460         }
3461         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3462     }
3463
3464     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3465
3466     return retval;
3467 }
3468
3469 /*
3470 =head1 Compile-time scope hooks
3471
3472 =for apidoc Aox||blockhook_register
3473
3474 Register a set of hooks to be called when the Perl lexical scope changes
3475 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3476
3477 =cut
3478 */
3479
3480 void
3481 Perl_blockhook_register(pTHX_ BHK *hk)
3482 {
3483     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3484
3485     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3486 }
3487
3488 STATIC OP *
3489 S_newDEFSVOP(pTHX)
3490 {
3491     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3492     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3493         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3494     }
3495     else {
3496         OP * const o = newOP(OP_PADSV, 0);
3497         o->op_targ = offset;
3498         return o;
3499     }
3500 }
3501
3502 void
3503 Perl_newPROG(pTHX_ OP *o)
3504 {
3505     PERL_ARGS_ASSERT_NEWPROG;
3506
3507     if (PL_in_eval) {
3508         PERL_CONTEXT *cx;
3509         I32 i;
3510         if (PL_eval_root)
3511                 return;
3512         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3513                                ((PL_in_eval & EVAL_KEEPERR)
3514                                 ? OPf_SPECIAL : 0), o);
3515
3516         cx = &cxstack[cxstack_ix];
3517         assert(CxTYPE(cx) == CXt_EVAL);
3518
3519         if ((cx->blk_gimme & G_WANT) == G_VOID)
3520             scalarvoid(PL_eval_root);
3521         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3522             list(PL_eval_root);
3523         else
3524             scalar(PL_eval_root);
3525
3526         PL_eval_start = op_linklist(PL_eval_root);
3527         PL_eval_root->op_private |= OPpREFCOUNTED;
3528         OpREFCNT_set(PL_eval_root, 1);
3529         PL_eval_root->op_next = 0;
3530         i = PL_savestack_ix;
3531         SAVEFREEOP(o);
3532         ENTER;
3533         CALL_PEEP(PL_eval_start);
3534         finalize_optree(PL_eval_root);
3535         S_prune_chain_head(&PL_eval_start);
3536         LEAVE;
3537         PL_savestack_ix = i;
3538     }
3539     else {
3540         if (o->op_type == OP_STUB) {
3541             /* This block is entered if nothing is compiled for the main
3542                program. This will be the case for an genuinely empty main
3543                program, or one which only has BEGIN blocks etc, so already
3544                run and freed.
3545
3546                Historically (5.000) the guard above was !o. However, commit
3547                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3548                c71fccf11fde0068, changed perly.y so that newPROG() is now
3549                called with the output of block_end(), which returns a new
3550                OP_STUB for the case of an empty optree. ByteLoader (and
3551                maybe other things) also take this path, because they set up
3552                PL_main_start and PL_main_root directly, without generating an
3553                optree.
3554
3555                If the parsing the main program aborts (due to parse errors,
3556                or due to BEGIN or similar calling exit), then newPROG()
3557                isn't even called, and hence this code path and its cleanups
3558                are skipped. This shouldn't make a make a difference:
3559                * a non-zero return from perl_parse is a failure, and
3560                  perl_destruct() should be called immediately.
3561                * however, if exit(0) is called during the parse, then
3562                  perl_parse() returns 0, and perl_run() is called. As
3563                  PL_main_start will be NULL, perl_run() will return
3564                  promptly, and the exit code will remain 0.
3565             */
3566
3567             PL_comppad_name = 0;
3568             PL_compcv = 0;
3569             S_op_destroy(aTHX_ o);
3570             return;
3571         }
3572         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3573         PL_curcop = &PL_compiling;
3574         PL_main_start = LINKLIST(PL_main_root);
3575         PL_main_root->op_private |= OPpREFCOUNTED;
3576         OpREFCNT_set(PL_main_root, 1);
3577         PL_main_root->op_next = 0;
3578         CALL_PEEP(PL_main_start);
3579         finalize_optree(PL_main_root);
3580         S_prune_chain_head(&PL_main_start);
3581         cv_forget_slab(PL_compcv);
3582         PL_compcv = 0;
3583
3584         /* Register with debugger */
3585         if (PERLDB_INTER) {
3586             CV * const cv = get_cvs("DB::postponed", 0);
3587             if (cv) {
3588                 dSP;
3589                 PUSHMARK(SP);
3590                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3591                 PUTBACK;
3592                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3593             }
3594         }
3595     }
3596 }
3597
3598 OP *
3599 Perl_localize(pTHX_ OP *o, I32 lex)
3600 {
3601     PERL_ARGS_ASSERT_LOCALIZE;
3602
3603     if (o->op_flags & OPf_PARENS)
3604 /* [perl #17376]: this appears to be premature, and results in code such as
3605    C< our(%x); > executing in list mode rather than void mode */
3606 #if 0
3607         list(o);
3608 #else
3609         NOOP;
3610 #endif
3611     else {
3612         if ( PL_parser->bufptr > PL_parser->oldbufptr
3613             && PL_parser->bufptr[-1] == ','
3614             && ckWARN(WARN_PARENTHESIS))
3615         {
3616             char *s = PL_parser->bufptr;
3617             bool sigil = FALSE;
3618
3619             /* some heuristics to detect a potential error */
3620             while (*s && (strchr(", \t\n", *s)))
3621                 s++;
3622
3623             while (1) {
3624                 if (*s && strchr("@$%*", *s) && *++s
3625                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3626                     s++;
3627                     sigil = TRUE;
3628                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3629                         s++;
3630                     while (*s && (strchr(", \t\n", *s)))
3631                         s++;
3632                 }
3633                 else
3634                     break;
3635             }
3636             if (sigil && (*s == ';' || *s == '=')) {
3637                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3638                                 "Parentheses missing around \"%s\" list",
3639                                 lex
3640                                     ? (PL_parser->in_my == KEY_our
3641                                         ? "our"
3642                                         : PL_parser->in_my == KEY_state
3643                                             ? "state"
3644                                             : "my")
3645                                     : "local");
3646             }
3647         }
3648     }
3649     if (lex)
3650         o = my(o);
3651     else
3652         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3653     PL_parser->in_my = FALSE;
3654     PL_parser->in_my_stash = NULL;
3655     return o;
3656 }
3657
3658 OP *
3659 Perl_jmaybe(pTHX_ OP *o)
3660 {
3661     PERL_ARGS_ASSERT_JMAYBE;
3662
3663     if (o->op_type == OP_LIST) {
3664         OP * const o2
3665             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3666         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3667     }
3668     return o;
3669 }
3670
3671 PERL_STATIC_INLINE OP *
3672 S_op_std_init(pTHX_ OP *o)
3673 {
3674     I32 type = o->op_type;
3675
3676     PERL_ARGS_ASSERT_OP_STD_INIT;
3677
3678     if (PL_opargs[type] & OA_RETSCALAR)
3679         scalar(o);
3680     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3681         o->op_targ = pad_alloc(type, SVs_PADTMP);
3682
3683     return o;
3684 }
3685
3686 PERL_STATIC_INLINE OP *
3687 S_op_integerize(pTHX_ OP *o)
3688 {
3689     I32 type = o->op_type;
3690
3691     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3692
3693     /* integerize op. */
3694     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3695     {
3696         dVAR;
3697         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3698     }
3699
3700     if (type == OP_NEGATE)
3701         /* XXX might want a ck_negate() for this */
3702         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3703
3704     return o;
3705 }
3706
3707 static OP *
3708 S_fold_constants(pTHX_ OP *o)
3709 {
3710     dVAR;
3711     OP * VOL curop;
3712     OP *newop;
3713     VOL I32 type = o->op_type;
3714     SV * VOL sv = NULL;
3715     int ret = 0;
3716     I32 oldscope;
3717     OP *old_next;
3718     SV * const oldwarnhook = PL_warnhook;
3719     SV * const olddiehook  = PL_diehook;
3720     COP not_compiling;
3721     U8 oldwarn = PL_dowarn;
3722     dJMPENV;
3723
3724     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3725
3726     if (!(PL_opargs[type] & OA_FOLDCONST))
3727         goto nope;
3728
3729     switch (type) {
3730     case OP_UCFIRST:
3731     case OP_LCFIRST:
3732     case OP_UC:
3733     case OP_LC:
3734     case OP_FC:
3735 #ifdef USE_LOCALE_CTYPE
3736         if (IN_LC_COMPILETIME(LC_CTYPE))
3737             goto nope;
3738 #endif
3739         break;
3740     case OP_SLT:
3741     case OP_SGT:
3742     case OP_SLE:
3743     case OP_SGE:
3744     case OP_SCMP:
3745 #ifdef USE_LOCALE_COLLATE
3746         if (IN_LC_COMPILETIME(LC_COLLATE))
3747             goto nope;
3748 #endif
3749         break;
3750     case OP_SPRINTF:
3751         /* XXX what about the numeric ops? */
3752 #ifdef USE_LOCALE_NUMERIC
3753         if (IN_LC_COMPILETIME(LC_NUMERIC))
3754             goto nope;
3755 #endif
3756         break;
3757     case OP_PACK:
3758         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3759           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3760             goto nope;
3761         {
3762             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3763             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3764             {
3765                 const char *s = SvPVX_const(sv);
3766                 while (s < SvEND(sv)) {
3767                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3768                     s++;
3769                 }
3770             }
3771         }
3772         break;
3773     case OP_REPEAT:
3774         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3775         break;
3776     case OP_SREFGEN:
3777         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3778          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3779             goto nope;
3780     }
3781
3782     if (PL_parser && PL_parser->error_count)
3783         goto nope;              /* Don't try to run w/ errors */
3784
3785     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3786         const OPCODE type = curop->op_type;
3787         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3788             type != OP_LIST &&
3789             type != OP_SCALAR &&
3790             type != OP_NULL &&
3791             type != OP_PUSHMARK)
3792         {
3793             goto nope;
3794         }
3795     }
3796
3797     curop = LINKLIST(o);
3798     old_next = o->op_next;
3799     o->op_next = 0;
3800     PL_op = curop;
3801
3802     oldscope = PL_scopestack_ix;
3803     create_eval_scope(G_FAKINGEVAL);
3804
3805     /* Verify that we don't need to save it:  */
3806     assert(PL_curcop == &PL_compiling);
3807     StructCopy(&PL_compiling, &not_compiling, COP);
3808     PL_curcop = &not_compiling;
3809     /* The above ensures that we run with all the correct hints of the
3810        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3811     assert(IN_PERL_RUNTIME);
3812     PL_warnhook = PERL_WARNHOOK_FATAL;
3813     PL_diehook  = NULL;
3814     JMPENV_PUSH(ret);
3815
3816     /* Effective $^W=1.  */
3817     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3818         PL_dowarn |= G_WARN_ON;
3819
3820     switch (ret) {
3821     case 0:
3822         CALLRUNOPS(aTHX);
3823         sv = *(PL_stack_sp--);
3824         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3825             pad_swipe(o->op_targ,  FALSE);
3826         }
3827         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3828             SvREFCNT_inc_simple_void(sv);
3829             SvTEMP_off(sv);
3830         }
3831         else { assert(SvIMMORTAL(sv)); }
3832         break;
3833     case 3:
3834         /* Something tried to die.  Abandon constant folding.  */
3835         /* Pretend the error never happened.  */
3836         CLEAR_ERRSV();
3837         o->op_next = old_next;
3838         break;
3839     default:
3840         JMPENV_POP;
3841         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3842         PL_warnhook = oldwarnhook;
3843         PL_diehook  = olddiehook;
3844         /* XXX note that this croak may fail as we've already blown away
3845          * the stack - eg any nested evals */
3846         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3847     }
3848     JMPENV_POP;
3849     PL_dowarn   = oldwarn;
3850     PL_warnhook = oldwarnhook;
3851     PL_diehook  = olddiehook;
3852     PL_curcop = &PL_compiling;
3853
3854     if (PL_scopestack_ix > oldscope)
3855         delete_eval_scope();
3856
3857     if (ret)
3858         goto nope;
3859
3860     op_free(o);
3861     assert(sv);
3862     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3863     else if (!SvIMMORTAL(sv)) {
3864         SvPADTMP_on(sv);
3865         SvREADONLY_on(sv);
3866     }
3867     if (type == OP_RV2GV)
3868         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3869     else
3870     {
3871         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3872         if (type != OP_STRINGIFY) newop->op_folded = 1;
3873     }
3874     return newop;
3875
3876  nope:
3877     return o;
3878 }
3879
3880 static OP *
3881 S_gen_constant_list(pTHX_ OP *o)
3882 {
3883     dVAR;
3884     OP *curop;
3885     const SSize_t oldtmps_floor = PL_tmps_floor;
3886     SV **svp;
3887     AV *av;
3888
3889     list(o);
3890     if (PL_parser && PL_parser->error_count)
3891         return o;               /* Don't attempt to run with errors */
3892
3893     curop = LINKLIST(o);
3894     o->op_next = 0;
3895     CALL_PEEP(curop);
3896     S_prune_chain_head(&curop);
3897     PL_op = curop;
3898     Perl_pp_pushmark(aTHX);
3899     CALLRUNOPS(aTHX);
3900     PL_op = curop;
3901     assert (!(curop->op_flags & OPf_SPECIAL));
3902     assert(curop->op_type == OP_RANGE);
3903     Perl_pp_anonlist(aTHX);
3904     PL_tmps_floor = oldtmps_floor;
3905
3906     o->op_type = OP_RV2AV;
3907     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3908     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3909     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3910     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3911     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3912
3913     /* replace subtree with an OP_CONST */
3914     curop = ((UNOP*)o)->op_first;
3915     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3916     op_free(curop);
3917
3918     if (AvFILLp(av) != -1)
3919         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3920         {
3921             SvPADTMP_on(*svp);
3922             SvREADONLY_on(*svp);
3923         }
3924     LINKLIST(o);
3925     return list(o);
3926 }
3927
3928 /* convert o (and any siblings) into a list if not already, then
3929  * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
3930  */
3931
3932 OP *
3933 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3934 {
3935     dVAR;
3936     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3937     if (!o || o->op_type != OP_LIST)
3938         o = force_list(o, 0);
3939     else
3940         o->op_flags &= ~OPf_WANT;
3941
3942     if (!(PL_opargs[type] & OA_MARK))
3943         op_null(cLISTOPo->op_first);
3944     else {
3945         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3946         if (kid2 && kid2->op_type == OP_COREARGS) {
3947             op_null(cLISTOPo->op_first);
3948             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3949         }
3950     }   
3951
3952     o->op_type = (OPCODE)type;
3953     o->op_ppaddr = PL_ppaddr[type];
3954     o->op_flags |= flags;
3955
3956     o = CHECKOP(type, o);
3957     if (o->op_type != (unsigned)type)
3958         return o;
3959
3960     return fold_constants(op_integerize(op_std_init(o)));
3961 }
3962
3963 /*
3964 =head1 Optree Manipulation Functions
3965 */
3966
3967 /* List constructors */
3968
3969 /*
3970 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3971
3972 Append an item to the list of ops contained directly within a list-type
3973 op, returning the lengthened list.  I<first> is the list-type op,
3974 and I<last> is the op to append to the list.  I<optype> specifies the
3975 intended opcode for the list.  If I<first> is not already a list of the
3976 right type, it will be upgraded into one.  If either I<first> or I<last>
3977 is null, the other is returned unchanged.
3978
3979 =cut
3980 */
3981
3982 OP *
3983 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3984 {
3985     if (!first)
3986         return last;
3987
3988     if (!last)
3989         return first;
3990
3991     if (first->op_type != (unsigned)type
3992         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3993     {
3994         return newLISTOP(type, 0, first, last);
3995     }
3996
3997     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
3998     first->op_flags |= OPf_KIDS;
3999     return first;
4000 }
4001
4002 /*
4003 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4004
4005 Concatenate the lists of ops contained directly within two list-type ops,
4006 returning the combined list.  I<first> and I<last> are the list-type ops
4007 to concatenate.  I<optype> specifies the intended opcode for the list.
4008 If either I<first> or I<last> is not already a list of the right type,
4009 it will be upgraded into one.  If either I<first> or I<last> is null,
4010 the other is returned unchanged.
4011
4012 =cut
4013 */
4014
4015 OP *
4016 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4017 {
4018     if (!first)
4019         return last;
4020
4021     if (!last)
4022         return first;
4023
4024     if (first->op_type != (unsigned)type)
4025         return op_prepend_elem(type, first, last);
4026
4027     if (last->op_type != (unsigned)type)
4028         return op_append_elem(type, first, last);
4029
4030     ((LISTOP*)first)->op_last->op_lastsib = 0;
4031     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4032     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4033     ((LISTOP*)first)->op_last->op_lastsib = 1;
4034 #ifdef PERL_OP_PARENT
4035     ((LISTOP*)first)->op_last->op_sibling = first;
4036 #endif
4037     first->op_flags |= (last->op_flags & OPf_KIDS);
4038
4039
4040     S_op_destroy(aTHX_ last);
4041
4042     return first;
4043 }
4044
4045 /*
4046 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4047
4048 Prepend an item to the list of ops contained directly within a list-type
4049 op, returning the lengthened list.  I<first> is the op to prepend to the
4050 list, and I<last> is the list-type op.  I<optype> specifies the intended
4051 opcode for the list.  If I<last> is not already a list of the right type,
4052 it will be upgraded into one.  If either I<first> or I<last> is null,
4053 the other is returned unchanged.
4054
4055 =cut
4056 */
4057
4058 OP *
4059 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4060 {
4061     if (!first)
4062         return last;
4063
4064     if (!last)
4065         return first;
4066
4067     if (last->op_type == (unsigned)type) {
4068         if (type == OP_LIST) {  /* already a PUSHMARK there */
4069             /* insert 'first' after pushmark */
4070             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4071             if (!(first->op_flags & OPf_PARENS))
4072                 last->op_flags &= ~OPf_PARENS;
4073         }
4074         else
4075             op_sibling_splice(last, NULL, 0, first);
4076         last->op_flags |= OPf_KIDS;
4077         return last;
4078     }
4079
4080     return newLISTOP(type, 0, first, last);
4081 }
4082
4083 /* Constructors */
4084
4085
4086 /*
4087 =head1 Optree construction
4088
4089 =for apidoc Am|OP *|newNULLLIST
4090
4091 Constructs, checks, and returns a new C<stub> op, which represents an
4092 empty list expression.
4093
4094 =cut
4095 */
4096
4097 OP *
4098 Perl_newNULLLIST(pTHX)
4099 {
4100     return newOP(OP_STUB, 0);
4101 }
4102
4103 /* promote o and any siblings to be a list if its not already; i.e.
4104  *
4105  *  o - A - B
4106  *
4107  * becomes
4108  *
4109  *  list
4110  *    |
4111  *  pushmark - o - A - B
4112  *
4113  * If nullit it true, the list op is nulled.
4114  */
4115
4116 static OP *
4117 S_force_list(pTHX_ OP *o, bool nullit)
4118 {
4119     if (!o || o->op_type != OP_LIST) {
4120         OP *rest = NULL;
4121         if (o) {
4122             /* manually detach any siblings then add them back later */
4123             rest = OP_SIBLING(o);
4124             OP_SIBLING_set(o, NULL);
4125             o->op_lastsib = 1;
4126         }
4127         o = newLISTOP(OP_LIST, 0, o, NULL);
4128         if (rest)
4129             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4130     }
4131     if (nullit)
4132         op_null(o);
4133     return o;
4134 }
4135
4136 /*
4137 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4138
4139 Constructs, checks, and returns an op of any list type.  I<type> is
4140 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4141 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4142 supply up to two ops to be direct children of the list op; they are
4143 consumed by this function and become part of the constructed op tree.
4144
4145 =cut
4146 */
4147
4148 OP *
4149 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4150 {
4151     dVAR;
4152     LISTOP *listop;
4153
4154     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4155
4156     NewOp(1101, listop, 1, LISTOP);
4157
4158     listop->op_type = (OPCODE)type;
4159     listop->op_ppaddr = PL_ppaddr[type];
4160     if (first || last)
4161         flags |= OPf_KIDS;
4162     listop->op_flags = (U8)flags;
4163
4164     if (!last && first)
4165         last = first;
4166     else if (!first && last)
4167         first = last;
4168     else if (first)
4169         OP_SIBLING_set(first, last);
4170     listop->op_first = first;
4171     listop->op_last = last;
4172     if (type == OP_LIST) {
4173         OP* const pushop = newOP(OP_PUSHMARK, 0);
4174         pushop->op_lastsib = 0;
4175         OP_SIBLING_set(pushop, first);
4176         listop->op_first = pushop;
4177         listop->op_flags |= OPf_KIDS;
4178         if (!last)
4179             listop->op_last = pushop;
4180     }
4181     if (first)
4182         first->op_lastsib = 0;
4183     if (listop->op_last) {
4184         listop->op_last->op_lastsib = 1;
4185 #ifdef PERL_OP_PARENT
4186         listop->op_last->op_sibling = (OP*)listop;
4187 #endif
4188     }
4189
4190     return CHECKOP(type, listop);
4191 }
4192
4193 /*
4194 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4195
4196 Constructs, checks, and returns an op of any base type (any type that
4197 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4198 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4199 of C<op_private>.
4200
4201 =cut
4202 */
4203
4204 OP *
4205 Perl_newOP(pTHX_ I32 type, I32 flags)
4206 {
4207     dVAR;
4208     OP *o;
4209
4210     if (type == -OP_ENTEREVAL) {
4211         type = OP_ENTEREVAL;
4212         flags |= OPpEVAL_BYTES<<8;
4213     }
4214
4215     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4216         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4217         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4218         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4219
4220     NewOp(1101, o, 1, OP);
4221     o->op_type = (OPCODE)type;
4222     o->op_ppaddr = PL_ppaddr[type];
4223     o->op_flags = (U8)flags;
4224
4225     o->op_next = o;
4226     o->op_private = (U8)(0 | (flags >> 8));
4227     if (PL_opargs[type] & OA_RETSCALAR)
4228         scalar(o);
4229     if (PL_opargs[type] & OA_TARGET)
4230         o->op_targ = pad_alloc(type, SVs_PADTMP);
4231     return CHECKOP(type, o);
4232 }
4233
4234 /*
4235 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4236
4237 Constructs, checks, and returns an op of any unary type.  I<type> is
4238 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4239 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4240 bits, the eight bits of C<op_private>, except that the bit with value 1
4241 is automatically set.  I<first> supplies an optional op to be the direct
4242 child of the unary op; it is consumed by this function and become part
4243 of the constructed op tree.
4244
4245 =cut
4246 */
4247
4248 OP *
4249 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4250 {
4251     dVAR;
4252     UNOP *unop;
4253
4254     if (type == -OP_ENTEREVAL) {
4255         type = OP_ENTEREVAL;
4256         flags |= OPpEVAL_BYTES<<8;
4257     }
4258
4259     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4260         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4261         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4262         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4263         || type == OP_SASSIGN
4264         || type == OP_ENTERTRY
4265         || type == OP_NULL );
4266
4267     if (!first)
4268         first = newOP(OP_STUB, 0);
4269     if (PL_opargs[type] & OA_MARK)
4270         first = force_list(first, 1);
4271
4272     NewOp(1101, unop, 1, UNOP);
4273     unop->op_type = (OPCODE)type;
4274     unop->op_ppaddr = PL_ppaddr[type];
4275     unop->op_first = first;
4276     unop->op_flags = (U8)(flags | OPf_KIDS);
4277     unop->op_private = (U8)(1 | (flags >> 8));
4278
4279 #ifdef PERL_OP_PARENT
4280     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4281         first->op_sibling = (OP*)unop;
4282 #endif
4283
4284     unop = (UNOP*) CHECKOP(type, unop);
4285     if (unop->op_next)
4286         return (OP*)unop;
4287
4288     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4289 }
4290
4291 /*
4292 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4293
4294 Constructs, checks, and returns an op of any binary type.  I<type>
4295 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4296 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4297 the eight bits of C<op_private>, except that the bit with value 1 or
4298 2 is automatically set as required.  I<first> and I<last> supply up to
4299 two ops to be the direct children of the binary op; they are consumed
4300 by this function and become part of the constructed op tree.
4301
4302 =cut
4303 */
4304
4305 OP *
4306 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4307 {
4308     dVAR;
4309     BINOP *binop;
4310
4311     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4312         || type == OP_SASSIGN || type == OP_NULL );
4313
4314     NewOp(1101, binop, 1, BINOP);
4315
4316     if (!first)
4317         first = newOP(OP_NULL, 0);
4318
4319     binop->op_type = (OPCODE)type;
4320     binop->op_ppaddr = PL_ppaddr[type];
4321     binop->op_first = first;
4322     binop->op_flags = (U8)(flags | OPf_KIDS);
4323     if (!last) {
4324         last = first;
4325         binop->op_private = (U8)(1 | (flags >> 8));
4326     }
4327     else {
4328         binop->op_private = (U8)(2 | (flags >> 8));
4329         OP_SIBLING_set(first, last);
4330         first->op_lastsib = 0;
4331     }
4332
4333 #ifdef PERL_OP_PARENT
4334     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4335         last->op_sibling = (OP*)binop;
4336 #endif
4337
4338     binop = (BINOP*)CHECKOP(type, binop);
4339     if (binop->op_next || binop->op_type != (OPCODE)type)
4340         return (OP*)binop;
4341
4342     binop->op_last = OP_SIBLING(binop->op_first);
4343 #ifdef PERL_OP_PARENT
4344     if (binop->op_last)
4345         binop->op_last->op_sibling = (OP*)binop;
4346 #endif
4347
4348     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4349 }
4350
4351 static int uvcompare(const void *a, const void *b)
4352     __attribute__nonnull__(1)
4353     __attribute__nonnull__(2)
4354     __attribute__pure__;
4355 static int uvcompare(const void *a, const void *b)
4356 {
4357     if (*((const UV *)a) < (*(const UV *)b))
4358         return -1;
4359     if (*((const UV *)a) > (*(const UV *)b))
4360         return 1;
4361     if (*((const UV *)a+1) < (*(const UV *)b+1))
4362         return -1;
4363     if (*((const UV *)a+1) > (*(const UV *)b+1))
4364         return 1;
4365     return 0;
4366 }
4367
4368 static OP *
4369 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4370 {
4371     SV * const tstr = ((SVOP*)expr)->op_sv;
4372     SV * const rstr =
4373                               ((SVOP*)repl)->op_sv;
4374     STRLEN tlen;
4375     STRLEN rlen;
4376     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4377     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4378     I32 i;
4379     I32 j;
4380     I32 grows = 0;
4381     short *tbl;
4382
4383     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4384     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4385     I32 del              = o->op_private & OPpTRANS_DELETE;
4386     SV* swash;
4387
4388     PERL_ARGS_ASSERT_PMTRANS;
4389
4390     PL_hints |= HINT_BLOCK_SCOPE;
4391
4392     if (SvUTF8(tstr))
4393         o->op_private |= OPpTRANS_FROM_UTF;
4394
4395     if (SvUTF8(rstr))
4396         o->op_private |= OPpTRANS_TO_UTF;
4397
4398     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4399         SV* const listsv = newSVpvs("# comment\n");
4400         SV* transv = NULL;
4401         const U8* tend = t + tlen;
4402         const U8* rend = r + rlen;
4403         STRLEN ulen;
4404         UV tfirst = 1;
4405         UV tlast = 0;
4406         IV tdiff;
4407         UV rfirst = 1;
4408         UV rlast = 0;
4409         IV rdiff;
4410         IV diff;
4411         I32 none = 0;
4412         U32 max = 0;
4413         I32 bits;
4414         I32 havefinal = 0;
4415         U32 final = 0;
4416         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4417         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4418         U8* tsave = NULL;
4419         U8* rsave = NULL;
4420         const U32 flags = UTF8_ALLOW_DEFAULT;
4421
4422         if (!from_utf) {
4423             STRLEN len = tlen;
4424             t = tsave = bytes_to_utf8(t, &len);
4425             tend = t + len;
4426         }
4427         if (!to_utf && rlen) {
4428             STRLEN len = rlen;
4429             r = rsave = bytes_to_utf8(r, &len);
4430             rend = r + len;
4431         }
4432
4433 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4434  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4435  * odd.  */
4436
4437         if (complement) {
4438             U8 tmpbuf[UTF8_MAXBYTES+1];
4439             UV *cp;
4440             UV nextmin = 0;
4441             Newx(cp, 2*tlen, UV);
4442             i = 0;
4443             transv = newSVpvs("");
4444             while (t < tend) {
4445                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4446                 t += ulen;
4447                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4448                     t++;
4449                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4450                     t += ulen;
4451                 }
4452                 else {
4453                  cp[2*i+1] = cp[2*i];
4454                 }
4455                 i++;
4456             }
4457             qsort(cp, i, 2*sizeof(UV), uvcompare);
4458             for (j = 0; j < i; j++) {
4459                 UV  val = cp[2*j];
4460                 diff = val - nextmin;
4461                 if (diff > 0) {
4462                     t = uvchr_to_utf8(tmpbuf,nextmin);
4463                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4464                     if (diff > 1) {
4465                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4466                         t = uvchr_to_utf8(tmpbuf, val - 1);
4467                         sv_catpvn(transv, (char *)&range_mark, 1);
4468                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4469                     }
4470                 }
4471                 val = cp[2*j+1];
4472                 if (val >= nextmin)
4473                     nextmin = val + 1;
4474             }
4475             t = uvchr_to_utf8(tmpbuf,nextmin);
4476             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4477             {
4478                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4479                 sv_catpvn(transv, (char *)&range_mark, 1);
4480             }
4481             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4482             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4483             t = (const U8*)SvPVX_const(transv);
4484             tlen = SvCUR(transv);
4485             tend = t + tlen;
4486             Safefree(cp);
4487         }
4488         else if (!rlen && !del) {
4489             r = t; rlen = tlen; rend = tend;
4490         }
4491         if (!squash) {
4492                 if ((!rlen && !del) || t == r ||
4493                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4494                 {
4495                     o->op_private |= OPpTRANS_IDENTICAL;
4496                 }
4497         }
4498
4499         while (t < tend || tfirst <= tlast) {
4500             /* see if we need more "t" chars */
4501             if (tfirst > tlast) {
4502                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4503                 t += ulen;
4504                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4505                     t++;
4506                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4507                     t += ulen;
4508                 }
4509                 else
4510                     tlast = tfirst;
4511             }
4512
4513             /* now see if we need more "r" chars */
4514             if (rfirst > rlast) {
4515                 if (r < rend) {
4516                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4517                     r += ulen;
4518                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4519                         r++;
4520                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4521                         r += ulen;
4522                     }
4523                     else
4524                         rlast = rfirst;
4525                 }
4526                 else {
4527                     if (!havefinal++)
4528                         final = rlast;
4529                     rfirst = rlast = 0xffffffff;
4530                 }
4531             }
4532
4533             /* now see which range will peter our first, if either. */
4534             tdiff = tlast - tfirst;
4535             rdiff = rlast - rfirst;
4536
4537             if (tdiff <= rdiff)
4538                 diff = tdiff;
4539             else
4540                 diff = rdiff;
4541
4542             if (rfirst == 0xffffffff) {
4543                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4544                 if (diff > 0)
4545                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4546                                    (long)tfirst, (long)tlast);
4547                 else
4548                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4549             }
4550             else {
4551                 if (diff > 0)
4552                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4553                                    (long)tfirst, (long)(tfirst + diff),
4554                                    (long)rfirst);
4555                 else
4556                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4557                                    (long)tfirst, (long)rfirst);
4558
4559                 if (rfirst + diff > max)
4560                     max = rfirst + diff;
4561                 if (!grows)
4562                     grows = (tfirst < rfirst &&
4563                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4564                 rfirst += diff + 1;
4565             }
4566             tfirst += diff + 1;
4567         }
4568
4569         none = ++max;
4570         if (del)
4571             del = ++max;
4572
4573         if (max > 0xffff)
4574             bits = 32;
4575         else if (max > 0xff)
4576             bits = 16;
4577         else
4578             bits = 8;
4579
4580         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4581 #ifdef USE_ITHREADS
4582         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4583         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4584         PAD_SETSV(cPADOPo->op_padix, swash);
4585         SvPADTMP_on(swash);
4586         SvREADONLY_on(swash);
4587 #else
4588         cSVOPo->op_sv = swash;
4589 #endif
4590         SvREFCNT_dec(listsv);
4591         SvREFCNT_dec(transv);
4592
4593         if (!del && havefinal && rlen)
4594             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4595                            newSVuv((UV)final), 0);
4596
4597         if (grows)
4598             o->op_private |= OPpTRANS_GROWS;
4599
4600         Safefree(tsave);
4601         Safefree(rsave);
4602
4603         op_free(expr);
4604         op_free(repl);
4605         return o;
4606     }
4607
4608     tbl = (short*)PerlMemShared_calloc(
4609         (o->op_private & OPpTRANS_COMPLEMENT) &&
4610             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4611         sizeof(short));
4612     cPVOPo->op_pv = (char*)tbl;
4613     if (complement) {
4614         for (i = 0; i < (I32)tlen; i++)
4615             tbl[t[i]] = -1;
4616         for (i = 0, j = 0; i < 256; i++) {
4617             if (!tbl[i]) {
4618                 if (j >= (I32)rlen) {
4619                     if (del)
4620                         tbl[i] = -2;
4621                     else if (rlen)
4622                         tbl[i] = r[j-1];
4623                     else
4624                         tbl[i] = (short)i;
4625                 }
4626                 else {
4627                     if (i < 128 && r[j] >= 128)
4628                         grows = 1;
4629                     tbl[i] = r[j++];
4630                 }
4631             }
4632         }
4633         if (!del) {
4634             if (!rlen) {
4635                 j = rlen;
4636                 if (!squash)
4637                     o->op_private |= OPpTRANS_IDENTICAL;
4638             }
4639             else if (j >= (I32)rlen)
4640                 j = rlen - 1;
4641             else {
4642                 tbl = 
4643                     (short *)
4644                     PerlMemShared_realloc(tbl,
4645                                           (0x101+rlen-j) * sizeof(short));
4646                 cPVOPo->op_pv = (char*)tbl;
4647             }
4648             tbl[0x100] = (short)(rlen - j);
4649             for (i=0; i < (I32)rlen - j; i++)
4650                 tbl[0x101+i] = r[j+i];
4651         }
4652     }
4653     else {
4654         if (!rlen && !del) {
4655             r = t; rlen = tlen;
4656             if (!squash)
4657                 o->op_private |= OPpTRANS_IDENTICAL;
4658         }
4659         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4660             o->op_private |= OPpTRANS_IDENTICAL;
4661         }
4662         for (i = 0; i < 256; i++)
4663             tbl[i] = -1;
4664         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4665             if (j >= (I32)rlen) {
4666                 if (del) {
4667                     if (tbl[t[i]] == -1)
4668                         tbl[t[i]] = -2;
4669                     continue;
4670                 }
4671                 --j;
4672             }
4673             if (tbl[t[i]] == -1) {
4674                 if (t[i] < 128 && r[j] >= 128)
4675                     grows = 1;
4676                 tbl[t[i]] = r[j];
4677             }
4678         }
4679     }
4680
4681     if(del && rlen == tlen) {
4682         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
4683     } else if(rlen > tlen && !complement) {
4684         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4685     }
4686
4687     if (grows)
4688         o->op_private |= OPpTRANS_GROWS;
4689     op_free(expr);
4690     op_free(repl);
4691
4692     return o;
4693 }
4694
4695 /*
4696 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4697
4698 Constructs, checks, and returns an op of any pattern matching type.
4699 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4700 and, shifted up eight bits, the eight bits of C<op_private>.
4701
4702 =cut
4703 */
4704
4705 OP *
4706 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4707 {
4708     dVAR;
4709     PMOP *pmop;
4710
4711     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4712
4713     NewOp(1101, pmop, 1, PMOP);
4714     pmop->op_type = (OPCODE)type;
4715     pmop->op_ppaddr = PL_ppaddr[type];
4716     pmop->op_flags = (U8)flags;
4717     pmop->op_private = (U8)(0 | (flags >> 8));
4718
4719     if (PL_hints & HINT_RE_TAINT)
4720         pmop->op_pmflags |= PMf_RETAINT;
4721 #ifdef USE_LOCALE_CTYPE
4722     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4723         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4724     }
4725     else
4726 #endif
4727          if (IN_UNI_8_BIT) {
4728         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4729     }
4730     if (PL_hints & HINT_RE_FLAGS) {
4731         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4732          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4733         );
4734         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4735         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4736          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4737         );
4738         if (reflags && SvOK(reflags)) {
4739             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4740         }
4741     }
4742
4743
4744 #ifdef USE_ITHREADS
4745     assert(SvPOK(PL_regex_pad[0]));
4746     if (SvCUR(PL_regex_pad[0])) {
4747         /* Pop off the "packed" IV from the end.  */
4748         SV *const repointer_list = PL_regex_pad[0];
4749         const char *p = SvEND(repointer_list) - sizeof(IV);
4750         const IV offset = *((IV*)p);
4751
4752         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4753
4754         SvEND_set(repointer_list, p);
4755
4756         pmop->op_pmoffset = offset;
4757         /* This slot should be free, so assert this:  */
4758         assert(PL_regex_pad[offset] == &PL_sv_undef);
4759     } else {
4760         SV * const repointer = &PL_sv_undef;
4761         av_push(PL_regex_padav, repointer);
4762         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4763         PL_regex_pad = AvARRAY(PL_regex_padav);
4764     }
4765 #endif
4766
4767     return CHECKOP(type, pmop);
4768 }
4769
4770 /* Given some sort of match op o, and an expression expr containing a
4771  * pattern, either compile expr into a regex and attach it to o (if it's
4772  * constant), or convert expr into a runtime regcomp op sequence (if it's
4773  * not)
4774  *
4775  * isreg indicates that the pattern is part of a regex construct, eg
4776  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4777  * split "pattern", which aren't. In the former case, expr will be a list
4778  * if the pattern contains more than one term (eg /a$b/) or if it contains
4779  * a replacement, ie s/// or tr///.
4780  *
4781  * When the pattern has been compiled within a new anon CV (for
4782  * qr/(?{...})/ ), then floor indicates the savestack level just before
4783  * the new sub was created
4784  */
4785
4786 OP *
4787 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4788 {
4789     dVAR;
4790     PMOP *pm;
4791     LOGOP *rcop;
4792     I32 repl_has_vars = 0;
4793     OP* repl = NULL;
4794     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4795     bool is_compiletime;
4796     bool has_code;
4797
4798     PERL_ARGS_ASSERT_PMRUNTIME;
4799
4800     /* for s/// and tr///, last element in list is the replacement; pop it */
4801
4802     if (is_trans || o->op_type == OP_SUBST) {
4803         OP* kid;
4804         repl = cLISTOPx(expr)->op_last;
4805         kid = cLISTOPx(expr)->op_first;
4806         while (OP_SIBLING(kid) != repl)
4807             kid = OP_SIBLING(kid);
4808         op_sibling_splice(expr, kid, 1, NULL);
4809     }
4810
4811     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4812
4813     if (is_trans) {
4814         OP *first, *last;
4815
4816         assert(expr->op_type == OP_LIST);
4817         first = cLISTOPx(expr)->op_first;
4818         last  = cLISTOPx(expr)->op_last;
4819         assert(first->op_type == OP_PUSHMARK);
4820         assert(OP_SIBLING(first) == last);
4821
4822         /* cut 'last' from sibling chain, then free everything else */
4823         op_sibling_splice(expr, first, 1, NULL);
4824         op_free(expr);
4825
4826         return pmtrans(o, last, repl);
4827     }
4828
4829     /* find whether we have any runtime or code elements;
4830      * at the same time, temporarily set the op_next of each DO block;
4831      * then when we LINKLIST, this will cause the DO blocks to be excluded
4832      * from the op_next chain (and from having LINKLIST recursively
4833      * applied to them). We fix up the DOs specially later */
4834
4835     is_compiletime = 1;
4836     has_code = 0;
4837     if (expr->op_type == OP_LIST) {
4838         OP *o;
4839         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4840             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4841                 has_code = 1;
4842                 assert(!o->op_next && OP_HAS_SIBLING(o));
4843                 o->op_next = OP_SIBLING(o);
4844             }
4845             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4846                 is_compiletime = 0;
4847         }
4848     }
4849     else if (expr->op_type != OP_CONST)
4850         is_compiletime = 0;
4851
4852     LINKLIST(expr);
4853
4854     /* fix up DO blocks; treat each one as a separate little sub;
4855      * also, mark any arrays as LIST/REF */
4856
4857     if (expr->op_type == OP_LIST) {
4858         OP *o;
4859         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4860
4861             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4862                 assert( !(o->op_flags  & OPf_WANT));
4863                 /* push the array rather than its contents. The regex
4864                  * engine will retrieve and join the elements later */
4865                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4866                 continue;
4867             }
4868
4869             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4870                 continue;
4871             o->op_next = NULL; /* undo temporary hack from abov