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