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