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