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