This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Ensure that op_last always points to last sibling
[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
2185 #ifdef DEBUGGING
2186         /* check that op_last points to the last sibling */
2187         U32 type = o->op_type;
2188         U32 family;
2189
2190         if (type == OP_NULL) {
2191             type = o->op_targ;
2192             /* ck_glob creates a null UNOP with ex-type GLOB
2193              * (which is a list op. So pretend it wasn't a listop */
2194             if (type == OP_GLOB)
2195                 type = OP_NULL;
2196         }
2197         family = PL_opargs[type] & OA_CLASS_MASK;
2198
2199         if (
2200             /* XXX list form of 'x' is has a null op_last. This is wrong,
2201              * but requires too much hacking (e.g. in Deparse) to fix for
2202              * now */
2203             !(type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST))
2204             && (
2205                    family == OA_BINOP
2206                 || family == OA_LISTOP
2207                 || family == OA_PMOP
2208                 || family == OA_LOOP
2209             )
2210         )
2211         {
2212             OP *kid;
2213             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2214                 if (!OP_HAS_SIBLING(kid)) {
2215                     if (kid != cLISTOPo->op_last)
2216                     {
2217                         assert(kid == cLISTOPo->op_last);
2218                     }
2219                 }
2220             }
2221         }
2222 #endif
2223
2224         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2225             finalize_op(kid);
2226     }
2227 }
2228
2229 /*
2230 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2231
2232 Propagate lvalue ("modifiable") context to an op and its children.
2233 I<type> represents the context type, roughly based on the type of op that
2234 would do the modifying, although C<local()> is represented by OP_NULL,
2235 because it has no op type of its own (it is signalled by a flag on
2236 the lvalue op).
2237
2238 This function detects things that can't be modified, such as C<$x+1>, and
2239 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2240 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2241
2242 It also flags things that need to behave specially in an lvalue context,
2243 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2244
2245 =cut
2246 */
2247
2248 static bool
2249 S_vivifies(const OPCODE type)
2250 {
2251     switch(type) {
2252     case OP_RV2AV:     case   OP_ASLICE:
2253     case OP_RV2HV:     case OP_KVASLICE:
2254     case OP_RV2SV:     case   OP_HSLICE:
2255     case OP_AELEMFAST: case OP_KVHSLICE:
2256     case OP_HELEM:
2257     case OP_AELEM:
2258         return 1;
2259     }
2260     return 0;
2261 }
2262
2263 OP *
2264 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2265 {
2266     dVAR;
2267     OP *kid;
2268     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2269     int localize = -1;
2270
2271     if (!o || (PL_parser && PL_parser->error_count))
2272         return o;
2273
2274     if ((o->op_private & OPpTARGET_MY)
2275         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2276     {
2277         return o;
2278     }
2279
2280     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2281
2282     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2283
2284     switch (o->op_type) {
2285     case OP_UNDEF:
2286         PL_modcount++;
2287         return o;
2288     case OP_STUB:
2289         if ((o->op_flags & OPf_PARENS))
2290             break;
2291         goto nomod;
2292     case OP_ENTERSUB:
2293         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2294             !(o->op_flags & OPf_STACKED)) {
2295             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2296             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2297                poses, so we need it clear.  */
2298             o->op_private &= ~1;
2299             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2300             assert(cUNOPo->op_first->op_type == OP_NULL);
2301             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2302             break;
2303         }
2304         else {                          /* lvalue subroutine call */
2305             o->op_private |= OPpLVAL_INTRO
2306                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2307             PL_modcount = RETURN_UNLIMITED_NUMBER;
2308             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2309                 /* Potential lvalue context: */
2310                 o->op_private |= OPpENTERSUB_INARGS;
2311                 break;
2312             }
2313             else {                      /* Compile-time error message: */
2314                 OP *kid = cUNOPo->op_first;
2315                 CV *cv;
2316
2317                 if (kid->op_type != OP_PUSHMARK) {
2318                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2319                         Perl_croak(aTHX_
2320                                 "panic: unexpected lvalue entersub "
2321                                 "args: type/targ %ld:%"UVuf,
2322                                 (long)kid->op_type, (UV)kid->op_targ);
2323                     kid = kLISTOP->op_first;
2324                 }
2325                 while (OP_HAS_SIBLING(kid))
2326                     kid = OP_SIBLING(kid);
2327                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2328                     break;      /* Postpone until runtime */
2329                 }
2330
2331                 kid = kUNOP->op_first;
2332                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2333                     kid = kUNOP->op_first;
2334                 if (kid->op_type == OP_NULL)
2335                     Perl_croak(aTHX_
2336                                "Unexpected constant lvalue entersub "
2337                                "entry via type/targ %ld:%"UVuf,
2338                                (long)kid->op_type, (UV)kid->op_targ);
2339                 if (kid->op_type != OP_GV) {
2340                     break;
2341                 }
2342
2343                 cv = GvCV(kGVOP_gv);
2344                 if (!cv)
2345                     break;
2346                 if (CvLVALUE(cv))
2347                     break;
2348             }
2349         }
2350         /* FALLTHROUGH */
2351     default:
2352       nomod:
2353         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2354         /* grep, foreach, subcalls, refgen */
2355         if (type == OP_GREPSTART || type == OP_ENTERSUB
2356          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2357             break;
2358         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2359                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2360                       ? "do block"
2361                       : (o->op_type == OP_ENTERSUB
2362                         ? "non-lvalue subroutine call"
2363                         : OP_DESC(o))),
2364                      type ? PL_op_desc[type] : "local"));
2365         return o;
2366
2367     case OP_PREINC:
2368     case OP_PREDEC:
2369     case OP_POW:
2370     case OP_MULTIPLY:
2371     case OP_DIVIDE:
2372     case OP_MODULO:
2373     case OP_REPEAT:
2374     case OP_ADD:
2375     case OP_SUBTRACT:
2376     case OP_CONCAT:
2377     case OP_LEFT_SHIFT:
2378     case OP_RIGHT_SHIFT:
2379     case OP_BIT_AND:
2380     case OP_BIT_XOR:
2381     case OP_BIT_OR:
2382     case OP_I_MULTIPLY:
2383     case OP_I_DIVIDE:
2384     case OP_I_MODULO:
2385     case OP_I_ADD:
2386     case OP_I_SUBTRACT:
2387         if (!(o->op_flags & OPf_STACKED))
2388             goto nomod;
2389         PL_modcount++;
2390         break;
2391
2392     case OP_COND_EXPR:
2393         localize = 1;
2394         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2395             op_lvalue(kid, type);
2396         break;
2397
2398     case OP_RV2AV:
2399     case OP_RV2HV:
2400         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2401            PL_modcount = RETURN_UNLIMITED_NUMBER;
2402             return o;           /* Treat \(@foo) like ordinary list. */
2403         }
2404         /* FALLTHROUGH */
2405     case OP_RV2GV:
2406         if (scalar_mod_type(o, type))
2407             goto nomod;
2408         ref(cUNOPo->op_first, o->op_type);
2409         /* FALLTHROUGH */
2410     case OP_ASLICE:
2411     case OP_HSLICE:
2412         localize = 1;
2413         /* FALLTHROUGH */
2414     case OP_AASSIGN:
2415         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2416         if (type == OP_LEAVESUBLV && (
2417                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2418              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2419            ))
2420             o->op_private |= OPpMAYBE_LVSUB;
2421         /* FALLTHROUGH */
2422     case OP_NEXTSTATE:
2423     case OP_DBSTATE:
2424        PL_modcount = RETURN_UNLIMITED_NUMBER;
2425         break;
2426     case OP_KVHSLICE:
2427     case OP_KVASLICE:
2428         if (type == OP_LEAVESUBLV)
2429             o->op_private |= OPpMAYBE_LVSUB;
2430         goto nomod;
2431     case OP_AV2ARYLEN:
2432         PL_hints |= HINT_BLOCK_SCOPE;
2433         if (type == OP_LEAVESUBLV)
2434             o->op_private |= OPpMAYBE_LVSUB;
2435         PL_modcount++;
2436         break;
2437     case OP_RV2SV:
2438         ref(cUNOPo->op_first, o->op_type);
2439         localize = 1;
2440         /* FALLTHROUGH */
2441     case OP_GV:
2442         PL_hints |= HINT_BLOCK_SCOPE;
2443         /* FALLTHROUGH */
2444     case OP_SASSIGN:
2445     case OP_ANDASSIGN:
2446     case OP_ORASSIGN:
2447     case OP_DORASSIGN:
2448         PL_modcount++;
2449         break;
2450
2451     case OP_AELEMFAST:
2452     case OP_AELEMFAST_LEX:
2453         localize = -1;
2454         PL_modcount++;
2455         break;
2456
2457     case OP_PADAV:
2458     case OP_PADHV:
2459        PL_modcount = RETURN_UNLIMITED_NUMBER;
2460         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2461             return o;           /* Treat \(@foo) like ordinary list. */
2462         if (scalar_mod_type(o, type))
2463             goto nomod;
2464         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2465           && type == OP_LEAVESUBLV)
2466             o->op_private |= OPpMAYBE_LVSUB;
2467         /* FALLTHROUGH */
2468     case OP_PADSV:
2469         PL_modcount++;
2470         if (!type) /* local() */
2471             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2472                  PAD_COMPNAME_SV(o->op_targ));
2473         break;
2474
2475     case OP_PUSHMARK:
2476         localize = 0;
2477         break;
2478
2479     case OP_KEYS:
2480     case OP_RKEYS:
2481         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2482             goto nomod;
2483         goto lvalue_func;
2484     case OP_SUBSTR:
2485         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2486             goto nomod;
2487         /* FALLTHROUGH */
2488     case OP_POS:
2489     case OP_VEC:
2490       lvalue_func:
2491         if (type == OP_LEAVESUBLV)
2492             o->op_private |= OPpMAYBE_LVSUB;
2493         if (o->op_flags & OPf_KIDS)
2494             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2495         break;
2496
2497     case OP_AELEM:
2498     case OP_HELEM:
2499         ref(cBINOPo->op_first, o->op_type);
2500         if (type == OP_ENTERSUB &&
2501              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2502             o->op_private |= OPpLVAL_DEFER;
2503         if (type == OP_LEAVESUBLV)
2504             o->op_private |= OPpMAYBE_LVSUB;
2505         localize = 1;
2506         PL_modcount++;
2507         break;
2508
2509     case OP_LEAVE:
2510     case OP_LEAVELOOP:
2511         o->op_private |= OPpLVALUE;
2512         /* FALLTHROUGH */
2513     case OP_SCOPE:
2514     case OP_ENTER:
2515     case OP_LINESEQ:
2516         localize = 0;
2517         if (o->op_flags & OPf_KIDS)
2518             op_lvalue(cLISTOPo->op_last, type);
2519         break;
2520
2521     case OP_NULL:
2522         localize = 0;
2523         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2524             goto nomod;
2525         else if (!(o->op_flags & OPf_KIDS))
2526             break;
2527         if (o->op_targ != OP_LIST) {
2528             op_lvalue(cBINOPo->op_first, type);
2529             break;
2530         }
2531         /* FALLTHROUGH */
2532     case OP_LIST:
2533         localize = 0;
2534         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2535             /* elements might be in void context because the list is
2536                in scalar context or because they are attribute sub calls */
2537             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2538                 op_lvalue(kid, type);
2539         break;
2540
2541     case OP_RETURN:
2542         if (type != OP_LEAVESUBLV)
2543             goto nomod;
2544         break; /* op_lvalue()ing was handled by ck_return() */
2545
2546     case OP_COREARGS:
2547         return o;
2548
2549     case OP_AND:
2550     case OP_OR:
2551         if (type == OP_LEAVESUBLV
2552          || !S_vivifies(cLOGOPo->op_first->op_type))
2553             op_lvalue(cLOGOPo->op_first, type);
2554         if (type == OP_LEAVESUBLV
2555          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2556             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2557         goto nomod;
2558     }
2559
2560     /* [20011101.069] File test operators interpret OPf_REF to mean that
2561        their argument is a filehandle; thus \stat(".") should not set
2562        it. AMS 20011102 */
2563     if (type == OP_REFGEN &&
2564         PL_check[o->op_type] == Perl_ck_ftst)
2565         return o;
2566
2567     if (type != OP_LEAVESUBLV)
2568         o->op_flags |= OPf_MOD;
2569
2570     if (type == OP_AASSIGN || type == OP_SASSIGN)
2571         o->op_flags |= OPf_SPECIAL|OPf_REF;
2572     else if (!type) { /* local() */
2573         switch (localize) {
2574         case 1:
2575             o->op_private |= OPpLVAL_INTRO;
2576             o->op_flags &= ~OPf_SPECIAL;
2577             PL_hints |= HINT_BLOCK_SCOPE;
2578             break;
2579         case 0:
2580             break;
2581         case -1:
2582             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2583                            "Useless localization of %s", OP_DESC(o));
2584         }
2585     }
2586     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2587              && type != OP_LEAVESUBLV)
2588         o->op_flags |= OPf_REF;
2589     return o;
2590 }
2591
2592 STATIC bool
2593 S_scalar_mod_type(const OP *o, I32 type)
2594 {
2595     switch (type) {
2596     case OP_POS:
2597     case OP_SASSIGN:
2598         if (o && o->op_type == OP_RV2GV)
2599             return FALSE;
2600         /* FALLTHROUGH */
2601     case OP_PREINC:
2602     case OP_PREDEC:
2603     case OP_POSTINC:
2604     case OP_POSTDEC:
2605     case OP_I_PREINC:
2606     case OP_I_PREDEC:
2607     case OP_I_POSTINC:
2608     case OP_I_POSTDEC:
2609     case OP_POW:
2610     case OP_MULTIPLY:
2611     case OP_DIVIDE:
2612     case OP_MODULO:
2613     case OP_REPEAT:
2614     case OP_ADD:
2615     case OP_SUBTRACT:
2616     case OP_I_MULTIPLY:
2617     case OP_I_DIVIDE:
2618     case OP_I_MODULO:
2619     case OP_I_ADD:
2620     case OP_I_SUBTRACT:
2621     case OP_LEFT_SHIFT:
2622     case OP_RIGHT_SHIFT:
2623     case OP_BIT_AND:
2624     case OP_BIT_XOR:
2625     case OP_BIT_OR:
2626     case OP_CONCAT:
2627     case OP_SUBST:
2628     case OP_TRANS:
2629     case OP_TRANSR:
2630     case OP_READ:
2631     case OP_SYSREAD:
2632     case OP_RECV:
2633     case OP_ANDASSIGN:
2634     case OP_ORASSIGN:
2635     case OP_DORASSIGN:
2636         return TRUE;
2637     default:
2638         return FALSE;
2639     }
2640 }
2641
2642 STATIC bool
2643 S_is_handle_constructor(const OP *o, I32 numargs)
2644 {
2645     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2646
2647     switch (o->op_type) {
2648     case OP_PIPE_OP:
2649     case OP_SOCKPAIR:
2650         if (numargs == 2)
2651             return TRUE;
2652         /* FALLTHROUGH */
2653     case OP_SYSOPEN:
2654     case OP_OPEN:
2655     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2656     case OP_SOCKET:
2657     case OP_OPEN_DIR:
2658     case OP_ACCEPT:
2659         if (numargs == 1)
2660             return TRUE;
2661         /* FALLTHROUGH */
2662     default:
2663         return FALSE;
2664     }
2665 }
2666
2667 static OP *
2668 S_refkids(pTHX_ OP *o, I32 type)
2669 {
2670     if (o && o->op_flags & OPf_KIDS) {
2671         OP *kid;
2672         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2673             ref(kid, type);
2674     }
2675     return o;
2676 }
2677
2678 OP *
2679 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2680 {
2681     dVAR;
2682     OP *kid;
2683
2684     PERL_ARGS_ASSERT_DOREF;
2685
2686     if (!o || (PL_parser && PL_parser->error_count))
2687         return o;
2688
2689     switch (o->op_type) {
2690     case OP_ENTERSUB:
2691         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2692             !(o->op_flags & OPf_STACKED)) {
2693             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2694             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2695             assert(cUNOPo->op_first->op_type == OP_NULL);
2696             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2697             o->op_flags |= OPf_SPECIAL;
2698             o->op_private &= ~1;
2699         }
2700         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2701             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2702                               : type == OP_RV2HV ? OPpDEREF_HV
2703                               : OPpDEREF_SV);
2704             o->op_flags |= OPf_MOD;
2705         }
2706
2707         break;
2708
2709     case OP_COND_EXPR:
2710         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2711             doref(kid, type, set_op_ref);
2712         break;
2713     case OP_RV2SV:
2714         if (type == OP_DEFINED)
2715             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2716         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2717         /* FALLTHROUGH */
2718     case OP_PADSV:
2719         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2720             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2721                               : type == OP_RV2HV ? OPpDEREF_HV
2722                               : OPpDEREF_SV);
2723             o->op_flags |= OPf_MOD;
2724         }
2725         break;
2726
2727     case OP_RV2AV:
2728     case OP_RV2HV:
2729         if (set_op_ref)
2730             o->op_flags |= OPf_REF;
2731         /* FALLTHROUGH */
2732     case OP_RV2GV:
2733         if (type == OP_DEFINED)
2734             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2735         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2736         break;
2737
2738     case OP_PADAV:
2739     case OP_PADHV:
2740         if (set_op_ref)
2741             o->op_flags |= OPf_REF;
2742         break;
2743
2744     case OP_SCALAR:
2745     case OP_NULL:
2746         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2747             break;
2748         doref(cBINOPo->op_first, type, set_op_ref);
2749         break;
2750     case OP_AELEM:
2751     case OP_HELEM:
2752         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2753         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2754             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2755                               : type == OP_RV2HV ? OPpDEREF_HV
2756                               : OPpDEREF_SV);
2757             o->op_flags |= OPf_MOD;
2758         }
2759         break;
2760
2761     case OP_SCOPE:
2762     case OP_LEAVE:
2763         set_op_ref = FALSE;
2764         /* FALLTHROUGH */
2765     case OP_ENTER:
2766     case OP_LIST:
2767         if (!(o->op_flags & OPf_KIDS))
2768             break;
2769         doref(cLISTOPo->op_last, type, set_op_ref);
2770         break;
2771     default:
2772         break;
2773     }
2774     return scalar(o);
2775
2776 }
2777
2778 STATIC OP *
2779 S_dup_attrlist(pTHX_ OP *o)
2780 {
2781     OP *rop;
2782
2783     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2784
2785     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2786      * where the first kid is OP_PUSHMARK and the remaining ones
2787      * are OP_CONST.  We need to push the OP_CONST values.
2788      */
2789     if (o->op_type == OP_CONST)
2790         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2791     else {
2792         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2793         rop = NULL;
2794         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2795             if (o->op_type == OP_CONST)
2796                 rop = op_append_elem(OP_LIST, rop,
2797                                   newSVOP(OP_CONST, o->op_flags,
2798                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2799         }
2800     }
2801     return rop;
2802 }
2803
2804 STATIC void
2805 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2806 {
2807     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2808
2809     PERL_ARGS_ASSERT_APPLY_ATTRS;
2810
2811     /* fake up C<use attributes $pkg,$rv,@attrs> */
2812
2813 #define ATTRSMODULE "attributes"
2814 #define ATTRSMODULE_PM "attributes.pm"
2815
2816     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2817                          newSVpvs(ATTRSMODULE),
2818                          NULL,
2819                          op_prepend_elem(OP_LIST,
2820                                       newSVOP(OP_CONST, 0, stashsv),
2821                                       op_prepend_elem(OP_LIST,
2822                                                    newSVOP(OP_CONST, 0,
2823                                                            newRV(target)),
2824                                                    dup_attrlist(attrs))));
2825 }
2826
2827 STATIC void
2828 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2829 {
2830     OP *pack, *imop, *arg;
2831     SV *meth, *stashsv, **svp;
2832
2833     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2834
2835     if (!attrs)
2836         return;
2837
2838     assert(target->op_type == OP_PADSV ||
2839            target->op_type == OP_PADHV ||
2840            target->op_type == OP_PADAV);
2841
2842     /* Ensure that attributes.pm is loaded. */
2843     /* Don't force the C<use> if we don't need it. */
2844     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2845     if (svp && *svp != &PL_sv_undef)
2846         NOOP;   /* already in %INC */
2847     else
2848         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2849                                newSVpvs(ATTRSMODULE), NULL);
2850
2851     /* Need package name for method call. */
2852     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2853
2854     /* Build up the real arg-list. */
2855     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2856
2857     arg = newOP(OP_PADSV, 0);
2858     arg->op_targ = target->op_targ;
2859     arg = op_prepend_elem(OP_LIST,
2860                        newSVOP(OP_CONST, 0, stashsv),
2861                        op_prepend_elem(OP_LIST,
2862                                     newUNOP(OP_REFGEN, 0,
2863                                             op_lvalue(arg, OP_REFGEN)),
2864                                     dup_attrlist(attrs)));
2865
2866     /* Fake up a method call to import */
2867     meth = newSVpvs_share("import");
2868     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2869                    op_append_elem(OP_LIST,
2870                                op_prepend_elem(OP_LIST, pack, list(arg)),
2871                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2872
2873     /* Combine the ops. */
2874     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2875 }
2876
2877 /*
2878 =notfor apidoc apply_attrs_string
2879
2880 Attempts to apply a list of attributes specified by the C<attrstr> and
2881 C<len> arguments to the subroutine identified by the C<cv> argument which
2882 is expected to be associated with the package identified by the C<stashpv>
2883 argument (see L<attributes>).  It gets this wrong, though, in that it
2884 does not correctly identify the boundaries of the individual attribute
2885 specifications within C<attrstr>.  This is not really intended for the
2886 public API, but has to be listed here for systems such as AIX which
2887 need an explicit export list for symbols.  (It's called from XS code
2888 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2889 to respect attribute syntax properly would be welcome.
2890
2891 =cut
2892 */
2893
2894 void
2895 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2896                         const char *attrstr, STRLEN len)
2897 {
2898     OP *attrs = NULL;
2899
2900     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2901
2902     if (!len) {
2903         len = strlen(attrstr);
2904     }
2905
2906     while (len) {
2907         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2908         if (len) {
2909             const char * const sstr = attrstr;
2910             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2911             attrs = op_append_elem(OP_LIST, attrs,
2912                                 newSVOP(OP_CONST, 0,
2913                                         newSVpvn(sstr, attrstr-sstr)));
2914         }
2915     }
2916
2917     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2918                      newSVpvs(ATTRSMODULE),
2919                      NULL, op_prepend_elem(OP_LIST,
2920                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2921                                   op_prepend_elem(OP_LIST,
2922                                                newSVOP(OP_CONST, 0,
2923                                                        newRV(MUTABLE_SV(cv))),
2924                                                attrs)));
2925 }
2926
2927 STATIC void
2928 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2929 {
2930     OP *new_proto = NULL;
2931     STRLEN pvlen;
2932     char *pv;
2933     OP *o;
2934
2935     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2936
2937     if (!*attrs)
2938         return;
2939
2940     o = *attrs;
2941     if (o->op_type == OP_CONST) {
2942         pv = SvPV(cSVOPo_sv, pvlen);
2943         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2944             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2945             SV ** const tmpo = cSVOPx_svp(o);
2946             SvREFCNT_dec(cSVOPo_sv);
2947             *tmpo = tmpsv;
2948             new_proto = o;
2949             *attrs = NULL;
2950         }
2951     } else if (o->op_type == OP_LIST) {
2952         OP * lasto;
2953         assert(o->op_flags & OPf_KIDS);
2954         lasto = cLISTOPo->op_first;
2955         assert(lasto->op_type == OP_PUSHMARK);
2956         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
2957             if (o->op_type == OP_CONST) {
2958                 pv = SvPV(cSVOPo_sv, pvlen);
2959                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2960                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2961                     SV ** const tmpo = cSVOPx_svp(o);
2962                     SvREFCNT_dec(cSVOPo_sv);
2963                     *tmpo = tmpsv;
2964                     if (new_proto && ckWARN(WARN_MISC)) {
2965                         STRLEN new_len;
2966                         const char * newp = SvPV(cSVOPo_sv, new_len);
2967                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2968                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2969                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2970                         op_free(new_proto);
2971                     }
2972                     else if (new_proto)
2973                         op_free(new_proto);
2974                     new_proto = o;
2975                     /* excise new_proto from the list */
2976                     op_sibling_splice(*attrs, lasto, 1, NULL);
2977                     o = lasto;
2978                     continue;
2979                 }
2980             }
2981             lasto = o;
2982         }
2983         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2984            would get pulled in with no real need */
2985         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
2986             op_free(*attrs);
2987             *attrs = NULL;
2988         }
2989     }
2990
2991     if (new_proto) {
2992         SV *svname;
2993         if (isGV(name)) {
2994             svname = sv_newmortal();
2995             gv_efullname3(svname, name, NULL);
2996         }
2997         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2998             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2999         else
3000             svname = (SV *)name;
3001         if (ckWARN(WARN_ILLEGALPROTO))
3002             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3003         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3004             STRLEN old_len, new_len;
3005             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3006             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3007
3008             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3009                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3010                 " in %"SVf,
3011                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3012                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3013                 SVfARG(svname));
3014         }
3015         if (*proto)
3016             op_free(*proto);
3017         *proto = new_proto;
3018     }
3019 }
3020
3021 static void
3022 S_cant_declare(pTHX_ OP *o)
3023 {
3024     if (o->op_type == OP_NULL
3025      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3026         o = cUNOPo->op_first;
3027     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3028                              o->op_type == OP_NULL
3029                                && o->op_flags & OPf_SPECIAL
3030                                  ? "do block"
3031                                  : OP_DESC(o),
3032                              PL_parser->in_my == KEY_our   ? "our"   :
3033                              PL_parser->in_my == KEY_state ? "state" :
3034                                                              "my"));
3035 }
3036
3037 STATIC OP *
3038 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3039 {
3040     I32 type;
3041     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3042
3043     PERL_ARGS_ASSERT_MY_KID;
3044
3045     if (!o || (PL_parser && PL_parser->error_count))
3046         return o;
3047
3048     type = o->op_type;
3049
3050     if (type == OP_LIST) {
3051         OP *kid;
3052         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3053             my_kid(kid, attrs, imopsp);
3054         return o;
3055     } else if (type == OP_UNDEF || type == OP_STUB) {
3056         return o;
3057     } else if (type == OP_RV2SV ||      /* "our" declaration */
3058                type == OP_RV2AV ||
3059                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3060         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3061             S_cant_declare(aTHX_ o);
3062         } else if (attrs) {
3063             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3064             assert(PL_parser);
3065             PL_parser->in_my = FALSE;
3066             PL_parser->in_my_stash = NULL;
3067             apply_attrs(GvSTASH(gv),
3068                         (type == OP_RV2SV ? GvSV(gv) :
3069                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3070                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3071                         attrs);
3072         }
3073         o->op_private |= OPpOUR_INTRO;
3074         return o;
3075     }
3076     else if (type != OP_PADSV &&
3077              type != OP_PADAV &&
3078              type != OP_PADHV &&
3079              type != OP_PUSHMARK)
3080     {
3081         S_cant_declare(aTHX_ o);
3082         return o;
3083     }
3084     else if (attrs && type != OP_PUSHMARK) {
3085         HV *stash;
3086
3087         assert(PL_parser);
3088         PL_parser->in_my = FALSE;
3089         PL_parser->in_my_stash = NULL;
3090
3091         /* check for C<my Dog $spot> when deciding package */
3092         stash = PAD_COMPNAME_TYPE(o->op_targ);
3093         if (!stash)
3094             stash = PL_curstash;
3095         apply_attrs_my(stash, o, attrs, imopsp);
3096     }
3097     o->op_flags |= OPf_MOD;
3098     o->op_private |= OPpLVAL_INTRO;
3099     if (stately)
3100         o->op_private |= OPpPAD_STATE;
3101     return o;
3102 }
3103
3104 OP *
3105 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3106 {
3107     OP *rops;
3108     int maybe_scalar = 0;
3109
3110     PERL_ARGS_ASSERT_MY_ATTRS;
3111
3112 /* [perl #17376]: this appears to be premature, and results in code such as
3113    C< our(%x); > executing in list mode rather than void mode */
3114 #if 0
3115     if (o->op_flags & OPf_PARENS)
3116         list(o);
3117     else
3118         maybe_scalar = 1;
3119 #else
3120     maybe_scalar = 1;
3121 #endif
3122     if (attrs)
3123         SAVEFREEOP(attrs);
3124     rops = NULL;
3125     o = my_kid(o, attrs, &rops);
3126     if (rops) {
3127         if (maybe_scalar && o->op_type == OP_PADSV) {
3128             o = scalar(op_append_list(OP_LIST, rops, o));
3129             o->op_private |= OPpLVAL_INTRO;
3130         }
3131         else {
3132             /* The listop in rops might have a pushmark at the beginning,
3133                which will mess up list assignment. */
3134             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3135             if (rops->op_type == OP_LIST && 
3136                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3137             {
3138                 OP * const pushmark = lrops->op_first;
3139                 /* excise pushmark */
3140                 op_sibling_splice(rops, NULL, 1, NULL);
3141                 op_free(pushmark);
3142             }
3143             o = op_append_list(OP_LIST, o, rops);
3144         }
3145     }
3146     PL_parser->in_my = FALSE;
3147     PL_parser->in_my_stash = NULL;
3148     return o;
3149 }
3150
3151 OP *
3152 Perl_sawparens(pTHX_ OP *o)
3153 {
3154     PERL_UNUSED_CONTEXT;
3155     if (o)
3156         o->op_flags |= OPf_PARENS;
3157     return o;
3158 }
3159
3160 OP *
3161 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3162 {
3163     OP *o;
3164     bool ismatchop = 0;
3165     const OPCODE ltype = left->op_type;
3166     const OPCODE rtype = right->op_type;
3167
3168     PERL_ARGS_ASSERT_BIND_MATCH;
3169
3170     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3171           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3172     {
3173       const char * const desc
3174           = PL_op_desc[(
3175                           rtype == OP_SUBST || rtype == OP_TRANS
3176                        || rtype == OP_TRANSR
3177                        )
3178                        ? (int)rtype : OP_MATCH];
3179       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3180       SV * const name =
3181         S_op_varname(aTHX_ left);
3182       if (name)
3183         Perl_warner(aTHX_ packWARN(WARN_MISC),
3184              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3185              desc, SVfARG(name), SVfARG(name));
3186       else {
3187         const char * const sample = (isary
3188              ? "@array" : "%hash");
3189         Perl_warner(aTHX_ packWARN(WARN_MISC),
3190              "Applying %s to %s will act on scalar(%s)",
3191              desc, sample, sample);
3192       }
3193     }
3194
3195     if (rtype == OP_CONST &&
3196         cSVOPx(right)->op_private & OPpCONST_BARE &&
3197         cSVOPx(right)->op_private & OPpCONST_STRICT)
3198     {
3199         no_bareword_allowed(right);
3200     }
3201
3202     /* !~ doesn't make sense with /r, so error on it for now */
3203     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3204         type == OP_NOT)
3205         /* diag_listed_as: Using !~ with %s doesn't make sense */
3206         yyerror("Using !~ with s///r doesn't make sense");
3207     if (rtype == OP_TRANSR && type == OP_NOT)
3208         /* diag_listed_as: Using !~ with %s doesn't make sense */
3209         yyerror("Using !~ with tr///r doesn't make sense");
3210
3211     ismatchop = (rtype == OP_MATCH ||
3212                  rtype == OP_SUBST ||
3213                  rtype == OP_TRANS || rtype == OP_TRANSR)
3214              && !(right->op_flags & OPf_SPECIAL);
3215     if (ismatchop && right->op_private & OPpTARGET_MY) {
3216         right->op_targ = 0;
3217         right->op_private &= ~OPpTARGET_MY;
3218     }
3219     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3220         OP *newleft;
3221
3222         right->op_flags |= OPf_STACKED;
3223         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3224             ! (rtype == OP_TRANS &&
3225                right->op_private & OPpTRANS_IDENTICAL) &&
3226             ! (rtype == OP_SUBST &&
3227                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3228             newleft = op_lvalue(left, rtype);
3229         else
3230             newleft = left;
3231         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3232             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3233         else
3234             o = op_prepend_elem(rtype, scalar(newleft), right);
3235         if (type == OP_NOT)
3236             return newUNOP(OP_NOT, 0, scalar(o));
3237         return o;
3238     }
3239     else
3240         return bind_match(type, left,
3241                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3242 }
3243
3244 OP *
3245 Perl_invert(pTHX_ OP *o)
3246 {
3247     if (!o)
3248         return NULL;
3249     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3250 }
3251
3252 /*
3253 =for apidoc Amx|OP *|op_scope|OP *o
3254
3255 Wraps up an op tree with some additional ops so that at runtime a dynamic
3256 scope will be created.  The original ops run in the new dynamic scope,
3257 and then, provided that they exit normally, the scope will be unwound.
3258 The additional ops used to create and unwind the dynamic scope will
3259 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3260 instead if the ops are simple enough to not need the full dynamic scope
3261 structure.
3262
3263 =cut
3264 */
3265
3266 OP *
3267 Perl_op_scope(pTHX_ OP *o)
3268 {
3269     dVAR;
3270     if (o) {
3271         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3272             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3273             o->op_type = OP_LEAVE;
3274             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3275         }
3276         else if (o->op_type == OP_LINESEQ) {
3277             OP *kid;
3278             o->op_type = OP_SCOPE;
3279             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3280             kid = ((LISTOP*)o)->op_first;
3281             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3282                 op_null(kid);
3283
3284                 /* The following deals with things like 'do {1 for 1}' */
3285                 kid = OP_SIBLING(kid);
3286                 if (kid &&
3287                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3288                     op_null(kid);
3289             }
3290         }
3291         else
3292             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3293     }
3294     return o;
3295 }
3296
3297 OP *
3298 Perl_op_unscope(pTHX_ OP *o)
3299 {
3300     if (o && o->op_type == OP_LINESEQ) {
3301         OP *kid = cLISTOPo->op_first;
3302         for(; kid; kid = OP_SIBLING(kid))
3303             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3304                 op_null(kid);
3305     }
3306     return o;
3307 }
3308
3309 int
3310 Perl_block_start(pTHX_ int full)
3311 {
3312     const int retval = PL_savestack_ix;
3313
3314     pad_block_start(full);
3315     SAVEHINTS();
3316     PL_hints &= ~HINT_BLOCK_SCOPE;
3317     SAVECOMPILEWARNINGS();
3318     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3319
3320     CALL_BLOCK_HOOKS(bhk_start, full);
3321
3322     return retval;
3323 }
3324
3325 OP*
3326 Perl_block_end(pTHX_ I32 floor, OP *seq)
3327 {
3328     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3329     OP* retval = scalarseq(seq);
3330     OP *o;
3331
3332     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3333
3334     LEAVE_SCOPE(floor);
3335     if (needblockscope)
3336         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3337     o = pad_leavemy();
3338
3339     if (o) {
3340         /* pad_leavemy has created a sequence of introcv ops for all my
3341            subs declared in the block.  We have to replicate that list with
3342            clonecv ops, to deal with this situation:
3343
3344                sub {
3345                    my sub s1;
3346                    my sub s2;
3347                    sub s1 { state sub foo { \&s2 } }
3348                }->()
3349
3350            Originally, I was going to have introcv clone the CV and turn
3351            off the stale flag.  Since &s1 is declared before &s2, the
3352            introcv op for &s1 is executed (on sub entry) before the one for
3353            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3354            cloned, since it is a state sub) closes over &s2 and expects
3355            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3356            then &s2 is still marked stale.  Since &s1 is not active, and
3357            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3358            ble will not stay shared’ warning.  Because it is the same stub
3359            that will be used when the introcv op for &s2 is executed, clos-
3360            ing over it is safe.  Hence, we have to turn off the stale flag
3361            on all lexical subs in the block before we clone any of them.
3362            Hence, having introcv clone the sub cannot work.  So we create a
3363            list of ops like this:
3364
3365                lineseq
3366                   |
3367                   +-- introcv
3368                   |
3369                   +-- introcv
3370                   |
3371                   +-- introcv
3372                   |
3373                   .
3374                   .
3375                   .
3376                   |
3377                   +-- clonecv
3378                   |
3379                   +-- clonecv
3380                   |
3381                   +-- clonecv
3382                   |
3383                   .
3384                   .
3385                   .
3386          */
3387         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3388         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3389         for (;; kid = OP_SIBLING(kid)) {
3390             OP *newkid = newOP(OP_CLONECV, 0);
3391             newkid->op_targ = kid->op_targ;
3392             o = op_append_elem(OP_LINESEQ, o, newkid);
3393             if (kid == last) break;
3394         }
3395         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3396     }
3397
3398     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3399
3400     return retval;
3401 }
3402
3403 /*
3404 =head1 Compile-time scope hooks
3405
3406 =for apidoc Aox||blockhook_register
3407
3408 Register a set of hooks to be called when the Perl lexical scope changes
3409 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3410
3411 =cut
3412 */
3413
3414 void
3415 Perl_blockhook_register(pTHX_ BHK *hk)
3416 {
3417     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3418
3419     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3420 }
3421
3422 STATIC OP *
3423 S_newDEFSVOP(pTHX)
3424 {
3425     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3426     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3427         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3428     }
3429     else {
3430         OP * const o = newOP(OP_PADSV, 0);
3431         o->op_targ = offset;
3432         return o;
3433     }
3434 }
3435
3436 void
3437 Perl_newPROG(pTHX_ OP *o)
3438 {
3439     PERL_ARGS_ASSERT_NEWPROG;
3440
3441     if (PL_in_eval) {
3442         PERL_CONTEXT *cx;
3443         I32 i;
3444         if (PL_eval_root)
3445                 return;
3446         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3447                                ((PL_in_eval & EVAL_KEEPERR)
3448                                 ? OPf_SPECIAL : 0), o);
3449
3450         cx = &cxstack[cxstack_ix];
3451         assert(CxTYPE(cx) == CXt_EVAL);
3452
3453         if ((cx->blk_gimme & G_WANT) == G_VOID)
3454             scalarvoid(PL_eval_root);
3455         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3456             list(PL_eval_root);
3457         else
3458             scalar(PL_eval_root);
3459
3460         PL_eval_start = op_linklist(PL_eval_root);
3461         PL_eval_root->op_private |= OPpREFCOUNTED;
3462         OpREFCNT_set(PL_eval_root, 1);
3463         PL_eval_root->op_next = 0;
3464         i = PL_savestack_ix;
3465         SAVEFREEOP(o);
3466         ENTER;
3467         CALL_PEEP(PL_eval_start);
3468         finalize_optree(PL_eval_root);
3469         S_prune_chain_head(&PL_eval_start);
3470         LEAVE;
3471         PL_savestack_ix = i;
3472     }
3473     else {
3474         if (o->op_type == OP_STUB) {
3475             /* This block is entered if nothing is compiled for the main
3476                program. This will be the case for an genuinely empty main
3477                program, or one which only has BEGIN blocks etc, so already
3478                run and freed.
3479
3480                Historically (5.000) the guard above was !o. However, commit
3481                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3482                c71fccf11fde0068, changed perly.y so that newPROG() is now
3483                called with the output of block_end(), which returns a new
3484                OP_STUB for the case of an empty optree. ByteLoader (and
3485                maybe other things) also take this path, because they set up
3486                PL_main_start and PL_main_root directly, without generating an
3487                optree.
3488
3489                If the parsing the main program aborts (due to parse errors,
3490                or due to BEGIN or similar calling exit), then newPROG()
3491                isn't even called, and hence this code path and its cleanups
3492                are skipped. This shouldn't make a make a difference:
3493                * a non-zero return from perl_parse is a failure, and
3494                  perl_destruct() should be called immediately.
3495                * however, if exit(0) is called during the parse, then
3496                  perl_parse() returns 0, and perl_run() is called. As
3497                  PL_main_start will be NULL, perl_run() will return
3498                  promptly, and the exit code will remain 0.
3499             */
3500
3501             PL_comppad_name = 0;
3502             PL_compcv = 0;
3503             S_op_destroy(aTHX_ o);
3504             return;
3505         }
3506         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3507         PL_curcop = &PL_compiling;
3508         PL_main_start = LINKLIST(PL_main_root);
3509         PL_main_root->op_private |= OPpREFCOUNTED;
3510         OpREFCNT_set(PL_main_root, 1);
3511         PL_main_root->op_next = 0;
3512         CALL_PEEP(PL_main_start);
3513         finalize_optree(PL_main_root);
3514         S_prune_chain_head(&PL_main_start);
3515         cv_forget_slab(PL_compcv);
3516         PL_compcv = 0;
3517
3518         /* Register with debugger */
3519         if (PERLDB_INTER) {
3520             CV * const cv = get_cvs("DB::postponed", 0);
3521             if (cv) {
3522                 dSP;
3523                 PUSHMARK(SP);
3524                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3525                 PUTBACK;
3526                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3527             }
3528         }
3529     }
3530 }
3531
3532 OP *
3533 Perl_localize(pTHX_ OP *o, I32 lex)
3534 {
3535     PERL_ARGS_ASSERT_LOCALIZE;
3536
3537     if (o->op_flags & OPf_PARENS)
3538 /* [perl #17376]: this appears to be premature, and results in code such as
3539    C< our(%x); > executing in list mode rather than void mode */
3540 #if 0
3541         list(o);
3542 #else
3543         NOOP;
3544 #endif
3545     else {
3546         if ( PL_parser->bufptr > PL_parser->oldbufptr
3547             && PL_parser->bufptr[-1] == ','
3548             && ckWARN(WARN_PARENTHESIS))
3549         {
3550             char *s = PL_parser->bufptr;
3551             bool sigil = FALSE;
3552
3553             /* some heuristics to detect a potential error */
3554             while (*s && (strchr(", \t\n", *s)))
3555                 s++;
3556
3557             while (1) {
3558                 if (*s && strchr("@$%*", *s) && *++s
3559                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3560                     s++;
3561                     sigil = TRUE;
3562                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3563                         s++;
3564                     while (*s && (strchr(", \t\n", *s)))
3565                         s++;
3566                 }
3567                 else
3568                     break;
3569             }
3570             if (sigil && (*s == ';' || *s == '=')) {
3571                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3572                                 "Parentheses missing around \"%s\" list",
3573                                 lex
3574                                     ? (PL_parser->in_my == KEY_our
3575                                         ? "our"
3576                                         : PL_parser->in_my == KEY_state
3577                                             ? "state"
3578                                             : "my")
3579                                     : "local");
3580             }
3581         }
3582     }
3583     if (lex)
3584         o = my(o);
3585     else
3586         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3587     PL_parser->in_my = FALSE;
3588     PL_parser->in_my_stash = NULL;
3589     return o;
3590 }
3591
3592 OP *
3593 Perl_jmaybe(pTHX_ OP *o)
3594 {
3595     PERL_ARGS_ASSERT_JMAYBE;
3596
3597     if (o->op_type == OP_LIST) {
3598         OP * const o2
3599             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3600         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3601     }
3602     return o;
3603 }
3604
3605 PERL_STATIC_INLINE OP *
3606 S_op_std_init(pTHX_ OP *o)
3607 {
3608     I32 type = o->op_type;
3609
3610     PERL_ARGS_ASSERT_OP_STD_INIT;
3611
3612     if (PL_opargs[type] & OA_RETSCALAR)
3613         scalar(o);
3614     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3615         o->op_targ = pad_alloc(type, SVs_PADTMP);
3616
3617     return o;
3618 }
3619
3620 PERL_STATIC_INLINE OP *
3621 S_op_integerize(pTHX_ OP *o)
3622 {
3623     I32 type = o->op_type;
3624
3625     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3626
3627     /* integerize op. */
3628     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3629     {
3630         dVAR;
3631         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3632     }
3633
3634     if (type == OP_NEGATE)
3635         /* XXX might want a ck_negate() for this */
3636         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3637
3638     return o;
3639 }
3640
3641 static OP *
3642 S_fold_constants(pTHX_ OP *o)
3643 {
3644     dVAR;
3645     OP * VOL curop;
3646     OP *newop;
3647     VOL I32 type = o->op_type;
3648     SV * VOL sv = NULL;
3649     int ret = 0;
3650     I32 oldscope;
3651     OP *old_next;
3652     SV * const oldwarnhook = PL_warnhook;
3653     SV * const olddiehook  = PL_diehook;
3654     COP not_compiling;
3655     dJMPENV;
3656
3657     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3658
3659     if (!(PL_opargs[type] & OA_FOLDCONST))
3660         goto nope;
3661
3662     switch (type) {
3663     case OP_UCFIRST:
3664     case OP_LCFIRST:
3665     case OP_UC:
3666     case OP_LC:
3667     case OP_FC:
3668 #ifdef USE_LOCALE_CTYPE
3669         if (IN_LC_COMPILETIME(LC_CTYPE))
3670             goto nope;
3671 #endif
3672         break;
3673     case OP_SLT:
3674     case OP_SGT:
3675     case OP_SLE:
3676     case OP_SGE:
3677     case OP_SCMP:
3678 #ifdef USE_LOCALE_COLLATE
3679         if (IN_LC_COMPILETIME(LC_COLLATE))
3680             goto nope;
3681 #endif
3682         break;
3683     case OP_SPRINTF:
3684         /* XXX what about the numeric ops? */
3685 #ifdef USE_LOCALE_NUMERIC
3686         if (IN_LC_COMPILETIME(LC_NUMERIC))
3687             goto nope;
3688 #endif
3689         break;
3690     case OP_PACK:
3691         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3692           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3693             goto nope;
3694         {
3695             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3696             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3697             {
3698                 const char *s = SvPVX_const(sv);
3699                 while (s < SvEND(sv)) {
3700                     if (*s == 'p' || *s == 'P') goto nope;
3701                     s++;
3702                 }
3703             }
3704         }
3705         break;
3706     case OP_REPEAT:
3707         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3708         break;
3709     case OP_SREFGEN:
3710         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3711          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3712             goto nope;
3713     }
3714
3715     if (PL_parser && PL_parser->error_count)
3716         goto nope;              /* Don't try to run w/ errors */
3717
3718     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3719         const OPCODE type = curop->op_type;
3720         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3721             type != OP_LIST &&
3722             type != OP_SCALAR &&
3723             type != OP_NULL &&
3724             type != OP_PUSHMARK)
3725         {
3726             goto nope;
3727         }
3728     }
3729
3730     curop = LINKLIST(o);
3731     old_next = o->op_next;
3732     o->op_next = 0;
3733     PL_op = curop;
3734
3735     oldscope = PL_scopestack_ix;
3736     create_eval_scope(G_FAKINGEVAL);
3737
3738     /* Verify that we don't need to save it:  */
3739     assert(PL_curcop == &PL_compiling);
3740     StructCopy(&PL_compiling, &not_compiling, COP);
3741     PL_curcop = &not_compiling;
3742     /* The above ensures that we run with all the correct hints of the
3743        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3744     assert(IN_PERL_RUNTIME);
3745     PL_warnhook = PERL_WARNHOOK_FATAL;
3746     PL_diehook  = NULL;
3747     JMPENV_PUSH(ret);
3748
3749     switch (ret) {
3750     case 0:
3751         CALLRUNOPS(aTHX);
3752         sv = *(PL_stack_sp--);
3753         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3754             pad_swipe(o->op_targ,  FALSE);
3755         }
3756         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3757             SvREFCNT_inc_simple_void(sv);
3758             SvTEMP_off(sv);
3759         }
3760         else { assert(SvIMMORTAL(sv)); }
3761         break;
3762     case 3:
3763         /* Something tried to die.  Abandon constant folding.  */
3764         /* Pretend the error never happened.  */
3765         CLEAR_ERRSV();
3766         o->op_next = old_next;
3767         break;
3768     default:
3769         JMPENV_POP;
3770         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3771         PL_warnhook = oldwarnhook;
3772         PL_diehook  = olddiehook;
3773         /* XXX note that this croak may fail as we've already blown away
3774          * the stack - eg any nested evals */
3775         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3776     }
3777     JMPENV_POP;
3778     PL_warnhook = oldwarnhook;
3779     PL_diehook  = olddiehook;
3780     PL_curcop = &PL_compiling;
3781
3782     if (PL_scopestack_ix > oldscope)
3783         delete_eval_scope();
3784
3785     if (ret)
3786         goto nope;
3787
3788     op_free(o);
3789     assert(sv);
3790     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3791     else if (!SvIMMORTAL(sv)) {
3792         SvPADTMP_on(sv);
3793         SvREADONLY_on(sv);
3794     }
3795     if (type == OP_RV2GV)
3796         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3797     else
3798     {
3799         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3800         if (type != OP_STRINGIFY) newop->op_folded = 1;
3801     }
3802     return newop;
3803
3804  nope:
3805     return o;
3806 }
3807
3808 static OP *
3809 S_gen_constant_list(pTHX_ OP *o)
3810 {
3811     dVAR;
3812     OP *curop;
3813     const SSize_t oldtmps_floor = PL_tmps_floor;
3814     SV **svp;
3815     AV *av;
3816
3817     list(o);
3818     if (PL_parser && PL_parser->error_count)
3819         return o;               /* Don't attempt to run with errors */
3820
3821     curop = LINKLIST(o);
3822     o->op_next = 0;
3823     CALL_PEEP(curop);
3824     S_prune_chain_head(&curop);
3825     PL_op = curop;
3826     Perl_pp_pushmark(aTHX);
3827     CALLRUNOPS(aTHX);
3828     PL_op = curop;
3829     assert (!(curop->op_flags & OPf_SPECIAL));
3830     assert(curop->op_type == OP_RANGE);
3831     Perl_pp_anonlist(aTHX);
3832     PL_tmps_floor = oldtmps_floor;
3833
3834     o->op_type = OP_RV2AV;
3835     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3836     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3837     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3838     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3839     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3840
3841     /* replace subtree with an OP_CONST */
3842     curop = ((UNOP*)o)->op_first;
3843     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3844     op_free(curop);
3845
3846     if (AvFILLp(av) != -1)
3847         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3848         {
3849             SvPADTMP_on(*svp);
3850             SvREADONLY_on(*svp);
3851         }
3852     LINKLIST(o);
3853     return list(o);
3854 }
3855
3856 OP *
3857 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3858 {
3859     dVAR;
3860     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3861     if (!o || o->op_type != OP_LIST) {
3862         OP* last = o;
3863         o = newLISTOP(OP_LIST, 0, o, NULL);
3864         if (last) {
3865             while (OP_HAS_SIBLING(last))
3866                 last = OP_SIBLING(last);
3867             cLISTOPo->op_last = last;
3868         }
3869     }
3870     else
3871         o->op_flags &= ~OPf_WANT;
3872
3873     if (!(PL_opargs[type] & OA_MARK))
3874         op_null(cLISTOPo->op_first);
3875     else {
3876         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3877         if (kid2 && kid2->op_type == OP_COREARGS) {
3878             op_null(cLISTOPo->op_first);
3879             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3880         }
3881     }   
3882
3883     o->op_type = (OPCODE)type;
3884     o->op_ppaddr = PL_ppaddr[type];
3885     o->op_flags |= flags;
3886
3887     o = CHECKOP(type, o);
3888     if (o->op_type != (unsigned)type)
3889         return o;
3890
3891     return fold_constants(op_integerize(op_std_init(o)));
3892 }
3893
3894 /*
3895 =head1 Optree Manipulation Functions
3896 */
3897
3898 /* List constructors */
3899
3900 /*
3901 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3902
3903 Append an item to the list of ops contained directly within a list-type
3904 op, returning the lengthened list.  I<first> is the list-type op,
3905 and I<last> is the op to append to the list.  I<optype> specifies the
3906 intended opcode for the list.  If I<first> is not already a list of the
3907 right type, it will be upgraded into one.  If either I<first> or I<last>
3908 is null, the other is returned unchanged.
3909
3910 =cut
3911 */
3912
3913 OP *
3914 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3915 {
3916     if (!first)
3917         return last;
3918
3919     if (!last)
3920         return first;
3921
3922     if (first->op_type != (unsigned)type
3923         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3924     {
3925         return newLISTOP(type, 0, first, last);
3926     }
3927
3928     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
3929     first->op_flags |= OPf_KIDS;
3930     return first;
3931 }
3932
3933 /*
3934 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3935
3936 Concatenate the lists of ops contained directly within two list-type ops,
3937 returning the combined list.  I<first> and I<last> are the list-type ops
3938 to concatenate.  I<optype> specifies the intended opcode for the list.
3939 If either I<first> or I<last> is not already a list of the right type,
3940 it will be upgraded into one.  If either I<first> or I<last> is null,
3941 the other is returned unchanged.
3942
3943 =cut
3944 */
3945
3946 OP *
3947 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3948 {
3949     if (!first)
3950         return last;
3951
3952     if (!last)
3953         return first;
3954
3955     if (first->op_type != (unsigned)type)
3956         return op_prepend_elem(type, first, last);
3957
3958     if (last->op_type != (unsigned)type)
3959         return op_append_elem(type, first, last);
3960
3961     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
3962     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3963     first->op_flags |= (last->op_flags & OPf_KIDS);
3964
3965
3966     S_op_destroy(aTHX_ last);
3967
3968     return first;
3969 }
3970
3971 /*
3972 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3973
3974 Prepend an item to the list of ops contained directly within a list-type
3975 op, returning the lengthened list.  I<first> is the op to prepend to the
3976 list, and I<last> is the list-type op.  I<optype> specifies the intended
3977 opcode for the list.  If I<last> is not already a list of the right type,
3978 it will be upgraded into one.  If either I<first> or I<last> is null,
3979 the other is returned unchanged.
3980
3981 =cut
3982 */
3983
3984 OP *
3985 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3986 {
3987     if (!first)
3988         return last;
3989
3990     if (!last)
3991         return first;
3992
3993     if (last->op_type == (unsigned)type) {
3994         if (type == OP_LIST) {  /* already a PUSHMARK there */
3995             /* insert 'first' after pushmark */
3996             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
3997             if (!(first->op_flags & OPf_PARENS))
3998                 last->op_flags &= ~OPf_PARENS;
3999         }
4000         else
4001             op_sibling_splice(last, NULL, 0, first);
4002         last->op_flags |= OPf_KIDS;
4003         return last;
4004     }
4005
4006     return newLISTOP(type, 0, first, last);
4007 }
4008
4009 /* Constructors */
4010
4011
4012 /*
4013 =head1 Optree construction
4014
4015 =for apidoc Am|OP *|newNULLLIST
4016
4017 Constructs, checks, and returns a new C<stub> op, which represents an
4018 empty list expression.
4019
4020 =cut
4021 */
4022
4023 OP *
4024 Perl_newNULLLIST(pTHX)
4025 {
4026     return newOP(OP_STUB, 0);
4027 }
4028
4029 static OP *
4030 S_force_list(pTHX_ OP *o)
4031 {
4032     if (!o || o->op_type != OP_LIST) {
4033         OP* last = o;
4034         o = newLISTOP(OP_LIST, 0, o, NULL);
4035         if (last) {
4036             while (OP_HAS_SIBLING(last))
4037                 last = OP_SIBLING(last);
4038             cLISTOPo->op_last = last;
4039         }
4040     }
4041     op_null(o);
4042     return o;
4043 }
4044
4045 /*
4046 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4047
4048 Constructs, checks, and returns an op of any list type.  I<type> is
4049 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4050 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4051 supply up to two ops to be direct children of the list op; they are
4052 consumed by this function and become part of the constructed op tree.
4053
4054 =cut
4055 */
4056
4057 OP *
4058 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4059 {
4060     dVAR;
4061     LISTOP *listop;
4062
4063     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4064
4065     NewOp(1101, listop, 1, LISTOP);
4066
4067     listop->op_type = (OPCODE)type;
4068     listop->op_ppaddr = PL_ppaddr[type];
4069     if (first || last)
4070         flags |= OPf_KIDS;
4071     listop->op_flags = (U8)flags;
4072
4073     if (!last && first)
4074         last = first;
4075     else if (!first && last)
4076         first = last;
4077     else if (first)
4078         OP_SIBLING_set(first, last);
4079     listop->op_first = first;
4080     listop->op_last = last;
4081     if (type == OP_LIST) {
4082         OP* const pushop = newOP(OP_PUSHMARK, 0);
4083         OP_SIBLING_set(pushop, first);
4084         listop->op_first = pushop;
4085         listop->op_flags |= OPf_KIDS;
4086         if (!last)
4087             listop->op_last = pushop;
4088     }
4089
4090     return CHECKOP(type, listop);
4091 }
4092
4093 /*
4094 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4095
4096 Constructs, checks, and returns an op of any base type (any type that
4097 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4098 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4099 of C<op_private>.
4100
4101 =cut
4102 */
4103
4104 OP *
4105 Perl_newOP(pTHX_ I32 type, I32 flags)
4106 {
4107     dVAR;
4108     OP *o;
4109
4110     if (type == -OP_ENTEREVAL) {
4111         type = OP_ENTEREVAL;
4112         flags |= OPpEVAL_BYTES<<8;
4113     }
4114
4115     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4116         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4117         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4118         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4119
4120     NewOp(1101, o, 1, OP);
4121     o->op_type = (OPCODE)type;
4122     o->op_ppaddr = PL_ppaddr[type];
4123     o->op_flags = (U8)flags;
4124
4125     o->op_next = o;
4126     o->op_private = (U8)(0 | (flags >> 8));
4127
4128     if (PL_opargs[type] & OA_RETSCALAR)
4129         scalar(o);
4130     if (PL_opargs[type] & OA_TARGET)
4131         o->op_targ = pad_alloc(type, SVs_PADTMP);
4132     return CHECKOP(type, o);
4133 }
4134
4135 /*
4136 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4137
4138 Constructs, checks, and returns an op of any unary type.  I<type> is
4139 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4140 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4141 bits, the eight bits of C<op_private>, except that the bit with value 1
4142 is automatically set.  I<first> supplies an optional op to be the direct
4143 child of the unary op; it is consumed by this function and become part
4144 of the constructed op tree.
4145
4146 =cut
4147 */
4148
4149 OP *
4150 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4151 {
4152     dVAR;
4153     UNOP *unop;
4154
4155     if (type == -OP_ENTEREVAL) {
4156         type = OP_ENTEREVAL;
4157         flags |= OPpEVAL_BYTES<<8;
4158     }
4159
4160     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4161         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4162         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4163         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4164         || type == OP_SASSIGN
4165         || type == OP_ENTERTRY
4166         || type == OP_NULL );
4167
4168     if (!first)
4169         first = newOP(OP_STUB, 0);
4170     if (PL_opargs[type] & OA_MARK)
4171         first = force_list(first);
4172
4173     NewOp(1101, unop, 1, UNOP);
4174     unop->op_type = (OPCODE)type;
4175     unop->op_ppaddr = PL_ppaddr[type];
4176     unop->op_first = first;
4177     unop->op_flags = (U8)(flags | OPf_KIDS);
4178     unop->op_private = (U8)(1 | (flags >> 8));
4179     unop = (UNOP*) CHECKOP(type, unop);
4180     if (unop->op_next)
4181         return (OP*)unop;
4182
4183     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4184 }
4185
4186 /*
4187 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4188
4189 Constructs, checks, and returns an op of any binary type.  I<type>
4190 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4191 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4192 the eight bits of C<op_private>, except that the bit with value 1 or
4193 2 is automatically set as required.  I<first> and I<last> supply up to
4194 two ops to be the direct children of the binary op; they are consumed
4195 by this function and become part of the constructed op tree.
4196
4197 =cut
4198 */
4199
4200 OP *
4201 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4202 {
4203     dVAR;
4204     BINOP *binop;
4205
4206     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4207         || type == OP_SASSIGN || type == OP_NULL );
4208
4209     NewOp(1101, binop, 1, BINOP);
4210
4211     if (!first)
4212         first = newOP(OP_NULL, 0);
4213
4214     binop->op_type = (OPCODE)type;
4215     binop->op_ppaddr = PL_ppaddr[type];
4216     binop->op_first = first;
4217     binop->op_flags = (U8)(flags | OPf_KIDS);
4218     if (!last) {
4219         last = first;
4220         binop->op_private = (U8)(1 | (flags >> 8));
4221     }
4222     else {
4223         binop->op_private = (U8)(2 | (flags >> 8));
4224         OP_SIBLING_set(first, last);
4225     }
4226
4227     binop = (BINOP*)CHECKOP(type, binop);
4228     if (binop->op_next || binop->op_type != (OPCODE)type)
4229         return (OP*)binop;
4230
4231     binop->op_last = OP_SIBLING(binop->op_first);
4232
4233     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4234 }
4235
4236 static int uvcompare(const void *a, const void *b)
4237     __attribute__nonnull__(1)
4238     __attribute__nonnull__(2)
4239     __attribute__pure__;
4240 static int uvcompare(const void *a, const void *b)
4241 {
4242     if (*((const UV *)a) < (*(const UV *)b))
4243         return -1;
4244     if (*((const UV *)a) > (*(const UV *)b))
4245         return 1;
4246     if (*((const UV *)a+1) < (*(const UV *)b+1))
4247         return -1;
4248     if (*((const UV *)a+1) > (*(const UV *)b+1))
4249         return 1;
4250     return 0;
4251 }
4252
4253 static OP *
4254 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4255 {
4256     SV * const tstr = ((SVOP*)expr)->op_sv;
4257     SV * const rstr =
4258                               ((SVOP*)repl)->op_sv;
4259     STRLEN tlen;
4260     STRLEN rlen;
4261     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4262     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4263     I32 i;
4264     I32 j;
4265     I32 grows = 0;
4266     short *tbl;
4267
4268     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4269     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4270     I32 del              = o->op_private & OPpTRANS_DELETE;
4271     SV* swash;
4272
4273     PERL_ARGS_ASSERT_PMTRANS;
4274
4275     PL_hints |= HINT_BLOCK_SCOPE;
4276
4277     if (SvUTF8(tstr))
4278         o->op_private |= OPpTRANS_FROM_UTF;
4279
4280     if (SvUTF8(rstr))
4281         o->op_private |= OPpTRANS_TO_UTF;
4282
4283     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4284         SV* const listsv = newSVpvs("# comment\n");
4285         SV* transv = NULL;
4286         const U8* tend = t + tlen;
4287         const U8* rend = r + rlen;
4288         STRLEN ulen;
4289         UV tfirst = 1;
4290         UV tlast = 0;
4291         IV tdiff;
4292         UV rfirst = 1;
4293         UV rlast = 0;
4294         IV rdiff;
4295         IV diff;
4296         I32 none = 0;
4297         U32 max = 0;
4298         I32 bits;
4299         I32 havefinal = 0;
4300         U32 final = 0;
4301         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4302         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4303         U8* tsave = NULL;
4304         U8* rsave = NULL;
4305         const U32 flags = UTF8_ALLOW_DEFAULT;
4306
4307         if (!from_utf) {
4308             STRLEN len = tlen;
4309             t = tsave = bytes_to_utf8(t, &len);
4310             tend = t + len;
4311         }
4312         if (!to_utf && rlen) {
4313             STRLEN len = rlen;
4314             r = rsave = bytes_to_utf8(r, &len);
4315             rend = r + len;
4316         }
4317
4318 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4319  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4320  * odd.  */
4321
4322         if (complement) {
4323             U8 tmpbuf[UTF8_MAXBYTES+1];
4324             UV *cp;
4325             UV nextmin = 0;
4326             Newx(cp, 2*tlen, UV);
4327             i = 0;
4328             transv = newSVpvs("");
4329             while (t < tend) {
4330                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4331                 t += ulen;
4332                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4333                     t++;
4334                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4335                     t += ulen;
4336                 }
4337                 else {
4338                  cp[2*i+1] = cp[2*i];
4339                 }
4340                 i++;
4341             }
4342             qsort(cp, i, 2*sizeof(UV), uvcompare);
4343             for (j = 0; j < i; j++) {
4344                 UV  val = cp[2*j];
4345                 diff = val - nextmin;
4346                 if (diff > 0) {
4347                     t = uvchr_to_utf8(tmpbuf,nextmin);
4348                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4349                     if (diff > 1) {
4350                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4351                         t = uvchr_to_utf8(tmpbuf, val - 1);
4352                         sv_catpvn(transv, (char *)&range_mark, 1);
4353                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4354                     }
4355                 }
4356                 val = cp[2*j+1];
4357                 if (val >= nextmin)
4358                     nextmin = val + 1;
4359             }
4360             t = uvchr_to_utf8(tmpbuf,nextmin);
4361             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4362             {
4363                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4364                 sv_catpvn(transv, (char *)&range_mark, 1);
4365             }
4366             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4367             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4368             t = (const U8*)SvPVX_const(transv);
4369             tlen = SvCUR(transv);
4370             tend = t + tlen;
4371             Safefree(cp);
4372         }
4373         else if (!rlen && !del) {
4374             r = t; rlen = tlen; rend = tend;
4375         }
4376         if (!squash) {
4377                 if ((!rlen && !del) || t == r ||
4378                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4379                 {
4380                     o->op_private |= OPpTRANS_IDENTICAL;
4381                 }
4382         }
4383
4384         while (t < tend || tfirst <= tlast) {
4385             /* see if we need more "t" chars */
4386             if (tfirst > tlast) {
4387                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4388                 t += ulen;
4389                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4390                     t++;
4391                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4392                     t += ulen;
4393                 }
4394                 else
4395                     tlast = tfirst;
4396             }
4397
4398             /* now see if we need more "r" chars */
4399             if (rfirst > rlast) {
4400                 if (r < rend) {
4401                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4402                     r += ulen;
4403                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4404                         r++;
4405                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4406                         r += ulen;
4407                     }
4408                     else
4409                         rlast = rfirst;
4410                 }
4411                 else {
4412                     if (!havefinal++)
4413                         final = rlast;
4414                     rfirst = rlast = 0xffffffff;
4415                 }
4416             }
4417
4418             /* now see which range will peter our first, if either. */
4419             tdiff = tlast - tfirst;
4420             rdiff = rlast - rfirst;
4421
4422             if (tdiff <= rdiff)
4423                 diff = tdiff;
4424             else
4425                 diff = rdiff;
4426
4427             if (rfirst == 0xffffffff) {
4428                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4429                 if (diff > 0)
4430                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4431                                    (long)tfirst, (long)tlast);
4432                 else
4433                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4434             }
4435             else {
4436                 if (diff > 0)
4437                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4438                                    (long)tfirst, (long)(tfirst + diff),
4439                                    (long)rfirst);
4440                 else
4441                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4442                                    (long)tfirst, (long)rfirst);
4443
4444                 if (rfirst + diff > max)
4445                     max = rfirst + diff;
4446                 if (!grows)
4447                     grows = (tfirst < rfirst &&
4448                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4449                 rfirst += diff + 1;
4450             }
4451             tfirst += diff + 1;
4452         }
4453
4454         none = ++max;
4455         if (del)
4456             del = ++max;
4457
4458         if (max > 0xffff)
4459             bits = 32;
4460         else if (max > 0xff)
4461             bits = 16;
4462         else
4463             bits = 8;
4464
4465         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4466 #ifdef USE_ITHREADS
4467         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4468         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4469         PAD_SETSV(cPADOPo->op_padix, swash);
4470         SvPADTMP_on(swash);
4471         SvREADONLY_on(swash);
4472 #else
4473         cSVOPo->op_sv = swash;
4474 #endif
4475         SvREFCNT_dec(listsv);
4476         SvREFCNT_dec(transv);
4477
4478         if (!del && havefinal && rlen)
4479             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4480                            newSVuv((UV)final), 0);
4481
4482         if (grows)
4483             o->op_private |= OPpTRANS_GROWS;
4484
4485         Safefree(tsave);
4486         Safefree(rsave);
4487
4488         op_free(expr);
4489         op_free(repl);
4490         return o;
4491     }
4492
4493     tbl = (short*)PerlMemShared_calloc(
4494         (o->op_private & OPpTRANS_COMPLEMENT) &&
4495             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4496         sizeof(short));
4497     cPVOPo->op_pv = (char*)tbl;
4498     if (complement) {
4499         for (i = 0; i < (I32)tlen; i++)
4500             tbl[t[i]] = -1;
4501         for (i = 0, j = 0; i < 256; i++) {
4502             if (!tbl[i]) {
4503                 if (j >= (I32)rlen) {
4504                     if (del)
4505                         tbl[i] = -2;
4506                     else if (rlen)
4507                         tbl[i] = r[j-1];
4508                     else
4509                         tbl[i] = (short)i;
4510                 }
4511                 else {
4512                     if (i < 128 && r[j] >= 128)
4513                         grows = 1;
4514                     tbl[i] = r[j++];
4515                 }
4516             }
4517         }
4518         if (!del) {
4519             if (!rlen) {
4520                 j = rlen;
4521                 if (!squash)
4522                     o->op_private |= OPpTRANS_IDENTICAL;
4523             }
4524             else if (j >= (I32)rlen)
4525                 j = rlen - 1;
4526             else {
4527                 tbl = 
4528                     (short *)
4529                     PerlMemShared_realloc(tbl,
4530                                           (0x101+rlen-j) * sizeof(short));
4531                 cPVOPo->op_pv = (char*)tbl;
4532             }
4533             tbl[0x100] = (short)(rlen - j);
4534             for (i=0; i < (I32)rlen - j; i++)
4535                 tbl[0x101+i] = r[j+i];
4536         }
4537     }
4538     else {
4539         if (!rlen && !del) {
4540             r = t; rlen = tlen;
4541             if (!squash)
4542                 o->op_private |= OPpTRANS_IDENTICAL;
4543         }
4544         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4545             o->op_private |= OPpTRANS_IDENTICAL;
4546         }
4547         for (i = 0; i < 256; i++)
4548             tbl[i] = -1;
4549         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4550             if (j >= (I32)rlen) {
4551                 if (del) {
4552                     if (tbl[t[i]] == -1)
4553                         tbl[t[i]] = -2;
4554                     continue;
4555                 }
4556                 --j;
4557             }
4558             if (tbl[t[i]] == -1) {
4559                 if (t[i] < 128 && r[j] >= 128)
4560                     grows = 1;
4561                 tbl[t[i]] = r[j];
4562             }
4563         }
4564     }
4565
4566     if(del && rlen == tlen) {
4567         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
4568     } else if(rlen > tlen && !complement) {
4569         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4570     }
4571
4572     if (grows)
4573         o->op_private |= OPpTRANS_GROWS;
4574     op_free(expr);
4575     op_free(repl);
4576
4577     return o;
4578 }
4579
4580 /*
4581 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4582
4583 Constructs, checks, and returns an op of any pattern matching type.
4584 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4585 and, shifted up eight bits, the eight bits of C<op_private>.
4586
4587 =cut
4588 */
4589
4590 OP *
4591 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4592 {
4593     dVAR;
4594     PMOP *pmop;
4595
4596     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4597
4598     NewOp(1101, pmop, 1, PMOP);
4599     pmop->op_type = (OPCODE)type;
4600     pmop->op_ppaddr = PL_ppaddr[type];
4601     pmop->op_flags = (U8)flags;
4602     pmop->op_private = (U8)(0 | (flags >> 8));
4603
4604     if (PL_hints & HINT_RE_TAINT)
4605         pmop->op_pmflags |= PMf_RETAINT;
4606 #ifdef USE_LOCALE_CTYPE
4607     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4608         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4609     }
4610     else
4611 #endif
4612          if (IN_UNI_8_BIT) {
4613         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4614     }
4615     if (PL_hints & HINT_RE_FLAGS) {
4616         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4617          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4618         );
4619         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4620         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4621          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4622         );
4623         if (reflags && SvOK(reflags)) {
4624             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4625         }
4626     }
4627
4628
4629 #ifdef USE_ITHREADS
4630     assert(SvPOK(PL_regex_pad[0]));
4631     if (SvCUR(PL_regex_pad[0])) {
4632         /* Pop off the "packed" IV from the end.  */
4633         SV *const repointer_list = PL_regex_pad[0];
4634         const char *p = SvEND(repointer_list) - sizeof(IV);
4635         const IV offset = *((IV*)p);
4636
4637         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4638
4639         SvEND_set(repointer_list, p);
4640
4641         pmop->op_pmoffset = offset;
4642         /* This slot should be free, so assert this:  */
4643         assert(PL_regex_pad[offset] == &PL_sv_undef);
4644     } else {
4645         SV * const repointer = &PL_sv_undef;
4646         av_push(PL_regex_padav, repointer);
4647         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4648         PL_regex_pad = AvARRAY(PL_regex_padav);
4649     }
4650 #endif
4651
4652     return CHECKOP(type, pmop);
4653 }
4654
4655 /* Given some sort of match op o, and an expression expr containing a
4656  * pattern, either compile expr into a regex and attach it to o (if it's
4657  * constant), or convert expr into a runtime regcomp op sequence (if it's
4658  * not)
4659  *
4660  * isreg indicates that the pattern is part of a regex construct, eg
4661  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4662  * split "pattern", which aren't. In the former case, expr will be a list
4663  * if the pattern contains more than one term (eg /a$b/) or if it contains
4664  * a replacement, ie s/// or tr///.
4665  *
4666  * When the pattern has been compiled within a new anon CV (for
4667  * qr/(?{...})/ ), then floor indicates the savestack level just before
4668  * the new sub was created
4669  */
4670
4671 OP *
4672 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4673 {
4674     dVAR;
4675     PMOP *pm;
4676     LOGOP *rcop;
4677     I32 repl_has_vars = 0;
4678     OP* repl = NULL;
4679     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4680     bool is_compiletime;
4681     bool has_code;
4682
4683     PERL_ARGS_ASSERT_PMRUNTIME;
4684
4685     /* for s/// and tr///, last element in list is the replacement; pop it */
4686
4687     if (is_trans || o->op_type == OP_SUBST) {
4688         OP* kid;
4689         repl = cLISTOPx(expr)->op_last;
4690         kid = cLISTOPx(expr)->op_first;
4691         while (OP_SIBLING(kid) != repl)
4692             kid = OP_SIBLING(kid);
4693         op_sibling_splice(expr, kid, 1, NULL);
4694     }
4695
4696     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4697
4698     if (is_trans) {
4699         OP *first, *last;
4700
4701         assert(expr->op_type == OP_LIST);
4702         first = cLISTOPx(expr)->op_first;
4703         last  = cLISTOPx(expr)->op_last;
4704         assert(first->op_type == OP_PUSHMARK);
4705         assert(OP_SIBLING(first) == last);
4706
4707         /* cut 'last' from sibling chain, then free everything else */
4708         op_sibling_splice(expr, first, 1, NULL);
4709         op_free(expr);
4710
4711         return pmtrans(o, last, repl);
4712     }
4713
4714     /* find whether we have any runtime or code elements;
4715      * at the same time, temporarily set the op_next of each DO block;
4716      * then when we LINKLIST, this will cause the DO blocks to be excluded
4717      * from the op_next chain (and from having LINKLIST recursively
4718      * applied to them). We fix up the DOs specially later */
4719
4720     is_compiletime = 1;
4721     has_code = 0;
4722     if (expr->op_type == OP_LIST) {
4723         OP *o;
4724         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4725             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4726                 has_code = 1;
4727                 assert(!o->op_next && OP_HAS_SIBLING(o));
4728                 o->op_next = OP_SIBLING(o);
4729             }
4730             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4731                 is_compiletime = 0;
4732         }
4733     }
4734     else if (expr->op_type != OP_CONST)
4735         is_compiletime = 0;
4736
4737     LINKLIST(expr);
4738
4739     /* fix up DO blocks; treat each one as a separate little sub;
4740      * also, mark any arrays as LIST/REF */
4741
4742     if (expr->op_type == OP_LIST) {
4743         OP *o;
4744         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4745
4746             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4747                 assert( !(o->op_flags  & OPf_WANT));
4748                 /* push the array rather than its contents. The regex
4749                  * engine will retrieve and join the elements later */
4750                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4751                 continue;
4752             }
4753
4754             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4755                 continue;
4756             o->op_next = NULL; /* undo temporary hack from above */
4757             scalar(o);
4758             LINKLIST(o);
4759             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4760                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4761                 /* skip ENTER */
4762                 assert(leaveop->op_first->op_type == OP_ENTER);
4763                 assert(OP_HAS_SIBLING(leaveop->op_first));
4764                 o->op_next = OP_SIBLING(leaveop->op_first);
4765                 /* skip leave */
4766                 assert(leaveop->op_flags & OPf_KIDS);
4767                 assert(leaveop->op_last->op_next == (OP*)leaveop);
4768                 leaveop->op_next = NULL; /* stop on last op */
4769                 op_null((OP*)leaveop);
4770             }
4771             else {
4772                 /* skip SCOPE */
4773                 OP *scope = cLISTOPo->op_first;
4774                 assert(scope->op_type == OP_SCOPE);
4775                 assert(scope->op_flags & OPf_KIDS);
4776                 scope->op_next = NULL; /* stop on last op */
4777                 op_null(scope);
4778             }
4779             /* have to peep the DOs individually as we've removed it from
4780              * the op_next chain */
4781             CALL_PEEP(o);
4782             S_prune_chain_head(&(o->op_next));
4783             if (is_compiletime)
4784                 /* runtime finalizes as part of finalizing whole tree */
4785                 finalize_optree(o);
4786         }
4787     }
4788     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4789         assert( !(expr->op_flags  & OPf_WANT));
4790         /* push the array rather than its contents. The regex
4791          * engine will retrieve and join the elements later */
4792         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4793     }
4794
4795     PL_hints |= HINT_BLOCK_SCOPE;
4796     pm = (PMOP*)o;
4797     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4798
4799     if (is_compiletime) {
4800         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4801         regexp_engine const *eng = current_re_engine();
4802
4803         if (o->op_flags & OPf_SPECIAL)
4804             rx_flags |= RXf_SPLIT;
4805
4806         if (!has_code || !eng->op_comp) {
4807             /* compile-time simple constant pattern */
4808
4809             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4810                 /* whoops! we guessed that a qr// had a code block, but we
4811                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4812                  * that isn't required now. Note that we have to be pretty
4813                  * confident that nothing used that CV's pad while the
4814                  * regex was parsed */
4815                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4816                 /* But we know that one op is using this CV's slab. */
4817                 cv_forget_slab(PL_compcv);
4818                 LEAVE_SCOPE(floor);
4819                 pm->op_pmflags &= ~PMf_HAS_CV;
4820             }
4821
4822             PM_SETRE(pm,
4823                 eng->op_comp
4824                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4825                                         rx_flags, pm->op_pmflags)
4826                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4827                                         rx_flags, pm->op_pmflags)
4828             );
4829             op_free(expr);
4830         }
4831         else {
4832             /* compile-time pattern that includes literal code blocks */
4833             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4834                         rx_flags,
4835                         (pm->op_pmflags |
4836                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4837                     );
4838             PM_SETRE(pm, re);
4839             if (pm->op_pmflags & PMf_HAS_CV) {
4840                 CV *cv;
4841                 /* this QR op (and the anon sub we embed it in) is never
4842                  * actually executed. It's just a placeholder where we can
4843                  * squirrel away expr in op_code_list without the peephole
4844    &