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