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