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