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