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