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