This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #78072] use re '/xism';
[perl5.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * A Perl program is compiled into a tree of OPs. Each op contains
26  * structural pointers (eg to its siblings and the next op in the
27  * execution sequence), a pointer to the function that would execute the
28  * op, plus any data specific to that op. For example, an OP_CONST op
29  * points to the pp_const() function and to an SV containing the constant
30  * value. When pp_const() is executed, its job is to push that SV onto the
31  * stack.
32  *
33  * OPs are mainly created by the newFOO() functions, which are mainly
34  * called from the parser (in perly.y) as the code is parsed. For example
35  * the Perl code $a + $b * $c would cause the equivalent of the following
36  * to be called (oversimplifying a bit):
37  *
38  *  newBINOP(OP_ADD, flags,
39  *      newSVREF($a),
40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41  *  )
42  *
43  * Note that during the build of miniperl, a temporary copy of this file
44  * is made, called opmini.c.
45  */
46
47 /*
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50     A bottom-up pass
51     A top-down pass
52     An execution-order pass
53
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines.  The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order.  (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
61 top level node.)
62
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again).  As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node.  But
70 it's still not the real execution order.
71
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer.  At that point, we can call
75 into peep() to do that code's portion of the 3rd pass.  It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
77 */
78
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80    get the compile time state of %^H for that block.  Storing %^H in every
81    block (or even COP) would be very expensive, so a different approach is
82    taken.  The (running) state of %^H is serialised into a tree of HE-like
83    structs.  Stores into %^H are chained onto the current leaf as a struct
84    refcounted_he * with the key and the value.  Deletes from %^H are saved
85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
86    turned back into a regular HV by walking back up the tree from that point's
87    leaf, ignoring any key you've already seen (placeholder or not), storing
88    the rest into the HV structure, then removing the placeholders. Hence
89    memory is only used to store the %^H deltas from the enclosing COP, rather
90    than the entire %^H on each COP.
91
92    To cause actions on %^H to write out the serialisation records, it has
93    magic type 'H'. This magic (itself) does nothing, but its presence causes
94    the values to gain magic type 'h', which has entries for set and clear.
95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98    it will be correctly restored when any inner compiling scope is exited.
99 */
100
101 #include "EXTERN.h"
102 #define PERL_IN_OP_C
103 #include "perl.h"
104 #include "keywords.h"
105
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     if (PL_hints & HINT_RE_FLAGS) {
3738         SV *reflags = Perl_refcounted_he_fetch(aTHX_
3739          PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags"), 0, 0
3740         );
3741         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
3742         reflags = Perl_refcounted_he_fetch(aTHX_
3743          PL_compiling.cop_hints_hash, 0, STR_WITH_LEN("reflags_dul"), 0, 0
3744         );
3745         if (reflags && SvOK(reflags)) {
3746             pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
3747             pmop->op_pmflags |= SvIV(reflags);
3748         }
3749     }
3750
3751
3752 #ifdef USE_ITHREADS
3753     assert(SvPOK(PL_regex_pad[0]));
3754     if (SvCUR(PL_regex_pad[0])) {
3755         /* Pop off the "packed" IV from the end.  */
3756         SV *const repointer_list = PL_regex_pad[0];
3757         const char *p = SvEND(repointer_list) - sizeof(IV);
3758         const IV offset = *((IV*)p);
3759
3760         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3761
3762         SvEND_set(repointer_list, p);
3763
3764         pmop->op_pmoffset = offset;
3765         /* This slot should be free, so assert this:  */
3766         assert(PL_regex_pad[offset] == &PL_sv_undef);
3767     } else {
3768         SV * const repointer = &PL_sv_undef;
3769         av_push(PL_regex_padav, repointer);
3770         pmop->op_pmoffset = av_len(PL_regex_padav);
3771         PL_regex_pad = AvARRAY(PL_regex_padav);
3772     }
3773 #endif
3774
3775     return CHECKOP(type, pmop);
3776 }
3777
3778 /* Given some sort of match op o, and an expression expr containing a
3779  * pattern, either compile expr into a regex and attach it to o (if it's
3780  * constant), or convert expr into a runtime regcomp op sequence (if it's
3781  * not)
3782  *
3783  * isreg indicates that the pattern is part of a regex construct, eg
3784  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3785  * split "pattern", which aren't. In the former case, expr will be a list
3786  * if the pattern contains more than one term (eg /a$b/) or if it contains
3787  * a replacement, ie s/// or tr///.
3788  */
3789
3790 OP *
3791 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3792 {
3793     dVAR;
3794     PMOP *pm;
3795     LOGOP *rcop;
3796     I32 repl_has_vars = 0;
3797     OP* repl = NULL;
3798     bool reglist;
3799
3800     PERL_ARGS_ASSERT_PMRUNTIME;
3801
3802     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3803         /* last element in list is the replacement; pop it */
3804         OP* kid;
3805         repl = cLISTOPx(expr)->op_last;
3806         kid = cLISTOPx(expr)->op_first;
3807         while (kid->op_sibling != repl)
3808             kid = kid->op_sibling;
3809         kid->op_sibling = NULL;
3810         cLISTOPx(expr)->op_last = kid;
3811     }
3812
3813     if (isreg && expr->op_type == OP_LIST &&
3814         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3815     {
3816         /* convert single element list to element */
3817         OP* const oe = expr;
3818         expr = cLISTOPx(oe)->op_first->op_sibling;
3819         cLISTOPx(oe)->op_first->op_sibling = NULL;
3820         cLISTOPx(oe)->op_last = NULL;
3821         op_free(oe);
3822     }
3823
3824     if (o->op_type == OP_TRANS) {
3825         return pmtrans(o, expr, repl);
3826     }
3827
3828     reglist = isreg && expr->op_type == OP_LIST;
3829     if (reglist)
3830         op_null(expr);
3831
3832     PL_hints |= HINT_BLOCK_SCOPE;
3833     pm = (PMOP*)o;
3834
3835     if (expr->op_type == OP_CONST) {
3836         SV *pat = ((SVOP*)expr)->op_sv;
3837         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3838
3839         if (o->op_flags & OPf_SPECIAL)
3840             pm_flags |= RXf_SPLIT;
3841
3842         if (DO_UTF8(pat)) {
3843             assert (SvUTF8(pat));
3844         } else if (SvUTF8(pat)) {
3845             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3846                trapped in use 'bytes'?  */
3847             /* Make a copy of the octet sequence, but without the flag on, as
3848                the compiler now honours the SvUTF8 flag on pat.  */
3849             STRLEN len;
3850             const char *const p = SvPV(pat, len);
3851             pat = newSVpvn_flags(p, len, SVs_TEMP);
3852         }
3853
3854         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3855
3856 #ifdef PERL_MAD
3857         op_getmad(expr,(OP*)pm,'e');
3858 #else
3859         op_free(expr);
3860 #endif
3861     }
3862     else {
3863         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3864             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3865                             ? OP_REGCRESET
3866                             : OP_REGCMAYBE),0,expr);
3867
3868         NewOp(1101, rcop, 1, LOGOP);
3869         rcop->op_type = OP_REGCOMP;
3870         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3871         rcop->op_first = scalar(expr);
3872         rcop->op_flags |= OPf_KIDS
3873                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3874                             | (reglist ? OPf_STACKED : 0);
3875         rcop->op_private = 1;
3876         rcop->op_other = o;
3877         if (reglist)
3878             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3879
3880         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3881         PL_cv_has_eval = 1;
3882
3883         /* establish postfix order */
3884         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3885             LINKLIST(expr);
3886             rcop->op_next = expr;
3887             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3888         }
3889         else {
3890             rcop->op_next = LINKLIST(expr);
3891             expr->op_next = (OP*)rcop;
3892         }
3893
3894         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
3895     }
3896
3897     if (repl) {
3898         OP *curop;
3899         if (pm->op_pmflags & PMf_EVAL) {
3900             curop = NULL;
3901             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3902                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3903         }
3904         else if (repl->op_type == OP_CONST)
3905             curop = repl;
3906         else {
3907             OP *lastop = NULL;
3908             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3909                 if (curop->op_type == OP_SCOPE
3910                         || curop->op_type == OP_LEAVE
3911                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3912                     if (curop->op_type == OP_GV) {
3913                         GV * const gv = cGVOPx_gv(curop);
3914                         repl_has_vars = 1;
3915                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3916                             break;
3917                     }
3918                     else if (curop->op_type == OP_RV2CV)
3919                         break;
3920                     else if (curop->op_type == OP_RV2SV ||
3921                              curop->op_type == OP_RV2AV ||
3922                              curop->op_type == OP_RV2HV ||
3923                              curop->op_type == OP_RV2GV) {
3924                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3925                             break;
3926                     }
3927                     else if (curop->op_type == OP_PADSV ||
3928                              curop->op_type == OP_PADAV ||
3929                              curop->op_type == OP_PADHV ||
3930                              curop->op_type == OP_PADANY)
3931                     {
3932                         repl_has_vars = 1;
3933                     }
3934                     else if (curop->op_type == OP_PUSHRE)
3935                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3936                     else
3937                         break;
3938                 }
3939                 lastop = curop;
3940             }
3941         }
3942         if (curop == repl
3943             && !(repl_has_vars
3944                  && (!PM_GETRE(pm)
3945                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3946         {
3947             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3948             op_prepend_elem(o->op_type, scalar(repl), o);
3949         }
3950         else {
3951             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3952                 pm->op_pmflags |= PMf_MAYBE_CONST;
3953             }
3954             NewOp(1101, rcop, 1, LOGOP);
3955             rcop->op_type = OP_SUBSTCONT;
3956             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3957             rcop->op_first = scalar(repl);
3958             rcop->op_flags |= OPf_KIDS;
3959             rcop->op_private = 1;
3960             rcop->op_other = o;
3961
3962             /* establish postfix order */
3963             rcop->op_next = LINKLIST(repl);
3964             repl->op_next = (OP*)rcop;
3965
3966             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3967             assert(!(pm->op_pmflags & PMf_ONCE));
3968             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3969             rcop->op_next = 0;
3970         }
3971     }
3972
3973     return (OP*)pm;
3974 }
3975
3976 /*
3977 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3978
3979 Constructs, checks, and returns an op of any type that involves an
3980 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
3981 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
3982 takes ownership of one reference to it.
3983
3984 =cut
3985 */
3986
3987 OP *
3988 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3989 {
3990     dVAR;
3991     SVOP *svop;
3992
3993     PERL_ARGS_ASSERT_NEWSVOP;
3994
3995     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3996         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3997         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3998
3999     NewOp(1101, svop, 1, SVOP);
4000     svop->op_type = (OPCODE)type;
4001     svop->op_ppaddr = PL_ppaddr[type];
4002     svop->op_sv = sv;
4003     svop->op_next = (OP*)svop;
4004     svop->op_flags = (U8)flags;
4005     if (PL_opargs[type] & OA_RETSCALAR)
4006         scalar((OP*)svop);
4007     if (PL_opargs[type] & OA_TARGET)
4008         svop->op_targ = pad_alloc(type, SVs_PADTMP);
4009     return CHECKOP(type, svop);
4010 }
4011
4012 #ifdef USE_ITHREADS
4013
4014 /*
4015 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4016
4017 Constructs, checks, and returns an op of any type that involves a
4018 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
4019 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
4020 is populated with I<sv>; this function takes ownership of one reference
4021 to it.
4022
4023 This function only exists if Perl has been compiled to use ithreads.
4024
4025 =cut
4026 */
4027
4028 OP *
4029 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4030 {
4031     dVAR;
4032     PADOP *padop;
4033
4034     PERL_ARGS_ASSERT_NEWPADOP;
4035
4036     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4037         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4038         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4039
4040     NewOp(1101, padop, 1, PADOP);
4041     padop->op_type = (OPCODE)type;
4042     padop->op_ppaddr = PL_ppaddr[type];
4043     padop->op_padix = pad_alloc(type, SVs_PADTMP);
4044     SvREFCNT_dec(PAD_SVl(padop->op_padix));
4045     PAD_SETSV(padop->op_padix, sv);
4046     assert(sv);
4047     SvPADTMP_on(sv);
4048     padop->op_next = (OP*)padop;
4049     padop->op_flags = (U8)flags;
4050     if (PL_opargs[type] & OA_RETSCALAR)
4051         scalar((OP*)padop);
4052     if (PL_opargs[type] & OA_TARGET)
4053         padop->op_targ = pad_alloc(type, SVs_PADTMP);
4054     return CHECKOP(type, padop);
4055 }
4056
4057 #endif /* !USE_ITHREADS */
4058
4059 /*
4060 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4061
4062 Constructs, checks, and returns an op of any type that involves an
4063 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
4064 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
4065 reference; calling this function does not transfer ownership of any
4066 reference to it.
4067
4068 =cut
4069 */
4070
4071 OP *
4072 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4073 {
4074     dVAR;
4075
4076     PERL_ARGS_ASSERT_NEWGVOP;
4077
4078 #ifdef USE_ITHREADS
4079     GvIN_PAD_on(gv);
4080     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4081 #else
4082     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4083 #endif
4084 }
4085
4086 /*
4087 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4088
4089 Constructs, checks, and returns an op of any type that involves an
4090 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
4091 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4092 must have been allocated using L</PerlMemShared_malloc>; the memory will
4093 be freed when the op is destroyed.
4094
4095 =cut
4096 */
4097
4098 OP *
4099 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4100 {
4101     dVAR;
4102     PVOP *pvop;
4103
4104     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4105         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4106
4107     NewOp(1101, pvop, 1, PVOP);
4108     pvop->op_type = (OPCODE)type;
4109     pvop->op_ppaddr = PL_ppaddr[type];
4110     pvop->op_pv = pv;
4111     pvop->op_next = (OP*)pvop;
4112     pvop->op_flags = (U8)flags;
4113     if (PL_opargs[type] & OA_RETSCALAR)
4114         scalar((OP*)pvop);
4115     if (PL_opargs[type] & OA_TARGET)
4116         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4117     return CHECKOP(type, pvop);
4118 }
4119
4120 #ifdef PERL_MAD
4121 OP*
4122 #else
4123 void
4124 #endif
4125 Perl_package(pTHX_ OP *o)
4126 {
4127     dVAR;
4128     SV *const sv = cSVOPo->op_sv;
4129 #ifdef PERL_MAD
4130     OP *pegop;
4131 #endif
4132
4133     PERL_ARGS_ASSERT_PACKAGE;
4134
4135     save_hptr(&PL_curstash);
4136     save_item(PL_curstname);
4137
4138     PL_curstash = gv_stashsv(sv, GV_ADD);
4139
4140     sv_setsv(PL_curstname, sv);
4141
4142     PL_hints |= HINT_BLOCK_SCOPE;
4143     PL_parser->copline = NOLINE;
4144     PL_parser->expect = XSTATE;
4145
4146 #ifndef PERL_MAD
4147     op_free(o);
4148 #else
4149     if (!PL_madskills) {
4150         op_free(o);
4151         return NULL;
4152     }
4153
4154     pegop = newOP(OP_NULL,0);
4155     op_getmad(o,pegop,'P');
4156     return pegop;
4157 #endif
4158 }
4159
4160 void
4161 Perl_package_version( pTHX_ OP *v )
4162 {
4163     dVAR;
4164     U32 savehints = PL_hints;
4165     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4166     PL_hints &= ~HINT_STRICT_VARS;
4167     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4168     PL_hints = savehints;
4169     op_free(v);
4170 }
4171
4172 #ifdef PERL_MAD
4173 OP*
4174 #else
4175 void
4176 #endif
4177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4178 {
4179     dVAR;
4180     OP *pack;
4181     OP *imop;
4182     OP *veop;
4183 #ifdef PERL_MAD
4184     OP *pegop = newOP(OP_NULL,0);
4185 #endif
4186
4187     PERL_ARGS_ASSERT_UTILIZE;
4188
4189     if (idop->op_type != OP_CONST)
4190         Perl_croak(aTHX_ "Module name must be constant");
4191
4192     if (PL_madskills)
4193         op_getmad(idop,pegop,'U');
4194
4195     veop = NULL;
4196
4197     if (version) {
4198         SV * const vesv = ((SVOP*)version)->op_sv;
4199
4200         if (PL_madskills)
4201             op_getmad(version,pegop,'V');
4202         if (!arg && !SvNIOKp(vesv)) {
4203             arg = version;
4204         }
4205         else {
4206             OP *pack;
4207             SV *meth;
4208
4209             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4210                 Perl_croak(aTHX_ "Version number must be a constant number");
4211
4212             /* Make copy of idop so we don't free it twice */
4213             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4214
4215             /* Fake up a method call to VERSION */
4216             meth = newSVpvs_share("VERSION");
4217             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4218                             op_append_elem(OP_LIST,
4219                                         op_prepend_elem(OP_LIST, pack, list(version)),
4220                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4221         }
4222     }
4223
4224     /* Fake up an import/unimport */
4225     if (arg && arg->op_type == OP_STUB) {
4226         if (PL_madskills)
4227             op_getmad(arg,pegop,'S');
4228         imop = arg;             /* no import on explicit () */
4229     }
4230     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4231         imop = NULL;            /* use 5.0; */
4232         if (!aver)
4233             idop->op_private |= OPpCONST_NOVER;
4234     }
4235     else {
4236         SV *meth;
4237
4238         if (PL_madskills)
4239             op_getmad(arg,pegop,'A');
4240
4241         /* Make copy of idop so we don't free it twice */
4242         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4243
4244         /* Fake up a method call to import/unimport */
4245         meth = aver
4246             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4247         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4248                        op_append_elem(OP_LIST,
4249                                    op_prepend_elem(OP_LIST, pack, list(arg)),
4250                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4251     }
4252
4253     /* Fake up the BEGIN {}, which does its thing immediately. */
4254     newATTRSUB(floor,
4255         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4256         NULL,
4257         NULL,
4258         op_append_elem(OP_LINESEQ,
4259             op_append_elem(OP_LINESEQ,
4260                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4261                 newSTATEOP(0, NULL, veop)),
4262             newSTATEOP(0, NULL, imop) ));
4263
4264     /* The "did you use incorrect case?" warning used to be here.
4265      * The problem is that on case-insensitive filesystems one
4266      * might get false positives for "use" (and "require"):
4267      * "use Strict" or "require CARP" will work.  This causes
4268      * portability problems for the script: in case-strict
4269      * filesystems the script will stop working.
4270      *
4271      * The "incorrect case" warning checked whether "use Foo"
4272      * imported "Foo" to your namespace, but that is wrong, too:
4273      * there is no requirement nor promise in the language that
4274      * a Foo.pm should or would contain anything in package "Foo".
4275      *
4276      * There is very little Configure-wise that can be done, either:
4277      * the case-sensitivity of the build filesystem of Perl does not
4278      * help in guessing the case-sensitivity of the runtime environment.
4279      */
4280
4281     PL_hints |= HINT_BLOCK_SCOPE;
4282     PL_parser->copline = NOLINE;
4283     PL_parser->expect = XSTATE;
4284     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4285
4286 #ifdef PERL_MAD
4287     if (!PL_madskills) {
4288         /* FIXME - don't allocate pegop if !PL_madskills */
4289         op_free(pegop);
4290         return NULL;
4291     }
4292     return pegop;
4293 #endif
4294 }
4295
4296 /*
4297 =head1 Embedding Functions
4298
4299 =for apidoc load_module
4300
4301 Loads the module whose name is pointed to by the string part of name.
4302 Note that the actual module name, not its filename, should be given.
4303 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4304 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4305 (or 0 for no flags). ver, if specified, provides version semantics
4306 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4307 arguments can be used to specify arguments to the module's import()
4308 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4309 terminated with a final NULL pointer.  Note that this list can only
4310 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4311 Otherwise at least a single NULL pointer to designate the default
4312 import list is required.
4313
4314 =cut */
4315
4316 void
4317 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4318 {
4319     va_list args;
4320
4321     PERL_ARGS_ASSERT_LOAD_MODULE;
4322
4323     va_start(args, ver);
4324     vload_module(flags, name, ver, &args);
4325     va_end(args);
4326 }
4327
4328 #ifdef PERL_IMPLICIT_CONTEXT
4329 void
4330 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4331 {
4332     dTHX;
4333     va_list args;
4334     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4335     va_start(args, ver);
4336     vload_module(flags, name, ver, &args);
4337     va_end(args);
4338 }
4339 #endif
4340
4341 void
4342 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4343 {
4344     dVAR;
4345     OP *veop, *imop;
4346     OP * const modname = newSVOP(OP_CONST, 0, name);
4347
4348     PERL_ARGS_ASSERT_VLOAD_MODULE;
4349
4350     modname->op_private |= OPpCONST_BARE;
4351     if (ver) {
4352         veop = newSVOP(OP_CONST, 0, ver);
4353     }
4354     else
4355         veop = NULL;
4356     if (flags & PERL_LOADMOD_NOIMPORT) {
4357         imop = sawparens(newNULLLIST());
4358     }
4359     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4360         imop = va_arg(*args, OP*);
4361     }
4362     else {
4363         SV *sv;
4364         imop = NULL;
4365         sv = va_arg(*args, SV*);
4366         while (sv) {
4367             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4368             sv = va_arg(*args, SV*);
4369         }
4370     }
4371
4372     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4373      * that it has a PL_parser to play with while doing that, and also
4374      * that it doesn't mess with any existing parser, by creating a tmp
4375      * new parser with lex_start(). This won't actually be used for much,
4376      * since pp_require() will create another parser for the real work. */
4377
4378     ENTER;
4379     SAVEVPTR(PL_curcop);
4380     lex_start(NULL, NULL, 0);
4381     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4382             veop, modname, imop);
4383     LEAVE;
4384 }
4385
4386 OP *
4387 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4388 {
4389     dVAR;
4390     OP *doop;
4391     GV *gv = NULL;
4392
4393     PERL_ARGS_ASSERT_DOFILE;
4394
4395     if (!force_builtin) {
4396         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4397         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4398             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4399             gv = gvp ? *gvp : NULL;
4400         }
4401     }
4402
4403     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4404         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4405                                op_append_elem(OP_LIST, term,
4406                                            scalar(newUNOP(OP_RV2CV, 0,
4407                                                           newGVOP(OP_GV, 0, gv))))));
4408     }
4409     else {
4410         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4411     }
4412     return doop;
4413 }
4414
4415 /*
4416 =head1 Optree construction
4417
4418 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4419
4420 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4421 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4422 be set automatically, and, shifted up eight bits, the eight bits of
4423 C<op_private>, except that the bit with value 1 or 2 is automatically
4424 set as required.  I<listval> and I<subscript> supply the parameters of
4425 the slice; they are consumed by this function and become part of the
4426 constructed op tree.
4427
4428 =cut
4429 */
4430
4431 OP *
4432 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4433 {
4434     return newBINOP(OP_LSLICE, flags,
4435             list(force_list(subscript)),
4436             list(force_list(listval)) );
4437 }
4438
4439 STATIC I32
4440 S_is_list_assignment(pTHX_ register const OP *o)
4441 {
4442     unsigned type;
4443     U8 flags;
4444
4445     if (!o)
4446         return TRUE;
4447
4448     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4449         o = cUNOPo->op_first;
4450
4451     flags = o->op_flags;
4452     type = o->op_type;
4453     if (type == OP_COND_EXPR) {
4454         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4455         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4456
4457         if (t && f)
4458             return TRUE;
4459         if (t || f)
4460             yyerror("Assignment to both a list and a scalar");
4461         return FALSE;
4462     }
4463
4464     if (type == OP_LIST &&
4465         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4466         o->op_private & OPpLVAL_INTRO)
4467         return FALSE;
4468
4469     if (type == OP_LIST || flags & OPf_PARENS ||
4470         type == OP_RV2AV || type == OP_RV2HV ||
4471         type == OP_ASLICE || type == OP_HSLICE)
4472         return TRUE;
4473
4474     if (type == OP_PADAV || type == OP_PADHV)
4475         return TRUE;
4476
4477     if (type == OP_RV2SV)
4478         return FALSE;
4479
4480     return FALSE;
4481 }
4482
4483 /*
4484 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4485
4486 Constructs, checks, and returns an assignment op.  I<left> and I<right>
4487 supply the parameters of the assignment; they are consumed by this
4488 function and become part of the constructed op tree.
4489
4490 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4491 a suitable conditional optree is constructed.  If I<optype> is the opcode
4492 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4493 performs the binary operation and assigns the result to the left argument.
4494 Either way, if I<optype> is non-zero then I<flags> has no effect.
4495
4496 If I<optype> is zero, then a plain scalar or list assignment is
4497 constructed.  Which type of assignment it is is automatically determined.
4498 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4499 will be set automatically, and, shifted up eight bits, the eight bits
4500 of C<op_private>, except that the bit with value 1 or 2 is automatically
4501 set as required.
4502
4503 =cut
4504 */
4505
4506 OP *
4507 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4508 {
4509     dVAR;
4510     OP *o;
4511
4512     if (optype) {
4513         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4514             return newLOGOP(optype, 0,
4515                 mod(scalar(left), optype),
4516                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4517         }
4518         else {
4519             return newBINOP(optype, OPf_STACKED,
4520                 mod(scalar(left), optype), scalar(right));
4521         }
4522     }
4523
4524     if (is_list_assignment(left)) {
4525         static const char no_list_state[] = "Initialization of state variables"
4526             " in list context currently forbidden";
4527         OP *curop;
4528         bool maybe_common_vars = TRUE;
4529
4530         PL_modcount = 0;
4531         /* Grandfathering $[ assignment here.  Bletch.*/
4532         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4533         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4534         left = mod(left, OP_AASSIGN);
4535         if (PL_eval_start)
4536             PL_eval_start = 0;
4537         else if (left->op_type == OP_CONST) {
4538             deprecate("assignment to $[");
4539             /* FIXME for MAD */
4540             /* Result of assignment is always 1 (or we'd be dead already) */
4541             return newSVOP(OP_CONST, 0, newSViv(1));
4542         }
4543         curop = list(force_list(left));
4544         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4545         o->op_private = (U8)(0 | (flags >> 8));
4546
4547         if ((left->op_type == OP_LIST
4548              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4549         {
4550             OP* lop = ((LISTOP*)left)->op_first;
4551             maybe_common_vars = FALSE;
4552             while (lop) {
4553                 if (lop->op_type == OP_PADSV ||
4554                     lop->op_type == OP_PADAV ||
4555                     lop->op_type == OP_PADHV ||
4556                     lop->op_type == OP_PADANY) {
4557                     if (!(lop->op_private & OPpLVAL_INTRO))
4558                         maybe_common_vars = TRUE;
4559
4560                     if (lop->op_private & OPpPAD_STATE) {
4561                         if (left->op_private & OPpLVAL_INTRO) {
4562                             /* Each variable in state($a, $b, $c) = ... */
4563                         }
4564                         else {
4565                             /* Each state variable in
4566                                (state $a, my $b, our $c, $d, undef) = ... */
4567                         }
4568                         yyerror(no_list_state);
4569                     } else {
4570                         /* Each my variable in
4571                            (state $a, my $b, our $c, $d, undef) = ... */
4572                     }
4573                 } else if (lop->op_type == OP_UNDEF ||
4574                            lop->op_type == OP_PUSHMARK) {
4575                     /* undef may be interesting in
4576                        (state $a, undef, state $c) */
4577                 } else {
4578                     /* Other ops in the list. */
4579                     maybe_common_vars = TRUE;
4580                 }
4581                 lop = lop->op_sibling;
4582             }
4583         }
4584         else if ((left->op_private & OPpLVAL_INTRO)
4585                 && (   left->op_type == OP_PADSV
4586                     || left->op_type == OP_PADAV
4587                     || left->op_type == OP_PADHV
4588                     || left->op_type == OP_PADANY))
4589         {
4590             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4591             if (left->op_private & OPpPAD_STATE) {
4592                 /* All single variable list context state assignments, hence
4593                    state ($a) = ...
4594                    (state $a) = ...
4595                    state @a = ...
4596                    state (@a) = ...
4597                    (state @a) = ...
4598                    state %a = ...
4599                    state (%a) = ...
4600                    (state %a) = ...
4601                 */
4602                 yyerror(no_list_state);
4603             }
4604         }
4605
4606         /* PL_generation sorcery:
4607          * an assignment like ($a,$b) = ($c,$d) is easier than
4608          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4609          * To detect whether there are common vars, the global var
4610          * PL_generation is incremented for each assign op we compile.
4611          * Then, while compiling the assign op, we run through all the
4612          * variables on both sides of the assignment, setting a spare slot
4613          * in each of them to PL_generation. If any of them already have
4614          * that value, we know we've got commonality.  We could use a
4615          * single bit marker, but then we'd have to make 2 passes, first
4616          * to clear the flag, then to test and set it.  To find somewhere
4617          * to store these values, evil chicanery is done with SvUVX().
4618          */
4619
4620         if (maybe_common_vars) {
4621             OP *lastop = o;
4622             PL_generation++;
4623             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4624                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4625                     if (curop->op_type == OP_GV) {
4626                         GV *gv = cGVOPx_gv(curop);
4627                         if (gv == PL_defgv
4628                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4629                             break;
4630                         GvASSIGN_GENERATION_set(gv, PL_generation);
4631                     }
4632                     else if (curop->op_type == OP_PADSV ||
4633                              curop->op_type == OP_PADAV ||
4634                              curop->op_type == OP_PADHV ||
4635                              curop->op_type == OP_PADANY)
4636                     {
4637                         if (PAD_COMPNAME_GEN(curop->op_targ)
4638                                                     == (STRLEN)PL_generation)
4639                             break;
4640                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4641
4642                     }
4643                     else if (curop->op_type == OP_RV2CV)
4644                         break;
4645                     else if (curop->op_type == OP_RV2SV ||
4646                              curop->op_type == OP_RV2AV ||
4647                              curop->op_type == OP_RV2HV ||
4648                              curop->op_type == OP_RV2GV) {
4649                         if (lastop->op_type != OP_GV)   /* funny deref? */
4650                             break;
4651                     }
4652                     else if (curop->op_type == OP_PUSHRE) {
4653 #ifdef USE_ITHREADS
4654                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4655                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4656                             if (gv == PL_defgv
4657                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4658                                 break;
4659                             GvASSIGN_GENERATION_set(gv, PL_generation);
4660                         }
4661 #else
4662                         GV *const gv
4663                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4664                         if (gv) {
4665                             if (gv == PL_defgv
4666                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4667                                 break;
4668                             GvASSIGN_GENERATION_set(gv, PL_generation);
4669                         }
4670 #endif
4671                     }
4672                     else
4673                         break;
4674                 }
4675                 lastop = curop;
4676             }
4677             if (curop != o)
4678                 o->op_private |= OPpASSIGN_COMMON;
4679         }
4680
4681         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4682             OP* tmpop = ((LISTOP*)right)->op_first;
4683             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4684                 PMOP * const pm = (PMOP*)tmpop;
4685                 if (left->op_type == OP_RV2AV &&
4686                     !(left->op_private & OPpLVAL_INTRO) &&
4687                     !(o->op_private & OPpASSIGN_COMMON) )
4688                 {
4689                     tmpop = ((UNOP*)left)->op_first;
4690                     if (tmpop->op_type == OP_GV
4691 #ifdef USE_ITHREADS
4692                         && !pm->op_pmreplrootu.op_pmtargetoff
4693 #else
4694                         && !pm->op_pmreplrootu.op_pmtargetgv
4695 #endif
4696                         ) {
4697 #ifdef USE_ITHREADS
4698                         pm->op_pmreplrootu.op_pmtargetoff
4699                             = cPADOPx(tmpop)->op_padix;
4700                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4701 #else
4702                         pm->op_pmreplrootu.op_pmtargetgv
4703                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4704                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4705 #endif
4706                         pm->op_pmflags |= PMf_ONCE;
4707                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4708                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4709                         tmpop->op_sibling = NULL;       /* don't free split */
4710                         right->op_next = tmpop->op_next;  /* fix starting loc */
4711                         op_free(o);                     /* blow off assign */
4712                         right->op_flags &= ~OPf_WANT;
4713                                 /* "I don't know and I don't care." */
4714                         return right;
4715                     }
4716                 }
4717                 else {
4718                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4719                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4720                     {
4721                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4722                         if (SvIOK(sv) && SvIVX(sv) == 0)
4723                             sv_setiv(sv, PL_modcount+1);
4724                     }
4725                 }
4726             }
4727         }
4728         return o;
4729     }
4730     if (!right)
4731         right = newOP(OP_UNDEF, 0);
4732     if (right->op_type == OP_READLINE) {
4733         right->op_flags |= OPf_STACKED;
4734         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4735     }
4736     else {
4737         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4738         o = newBINOP(OP_SASSIGN, flags,
4739             scalar(right), mod(scalar(left), OP_SASSIGN) );
4740         if (PL_eval_start)
4741             PL_eval_start = 0;
4742         else {
4743             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4744                 deprecate("assignment to $[");
4745                 op_free(o);
4746                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4747                 o->op_private |= OPpCONST_ARYBASE;
4748             }
4749         }
4750     }
4751     return o;
4752 }
4753
4754 /*
4755 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4756
4757 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
4758 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4759 code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4760 If I<label> is non-null, it supplies the name of a label to attach to
4761 the state op; this function takes ownership of the memory pointed at by
4762 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
4763 for the state op.
4764
4765 If I<o> is null, the state op is returned.  Otherwise the state op is
4766 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
4767 is consumed by this function and becomes part of the returned op tree.
4768
4769 =cut
4770 */
4771
4772 OP *
4773 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4774 {
4775     dVAR;
4776     const U32 seq = intro_my();
4777     register COP *cop;
4778
4779     NewOp(1101, cop, 1, COP);
4780     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4781         cop->op_type = OP_DBSTATE;
4782         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4783     }
4784     else {
4785         cop->op_type = OP_NEXTSTATE;
4786         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4787     }
4788     cop->op_flags = (U8)flags;
4789     CopHINTS_set(cop, PL_hints);
4790 #ifdef NATIVE_HINTS
4791     cop->op_private |= NATIVE_HINTS;
4792 #endif
4793     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4794     cop->op_next = (OP*)cop;
4795
4796     cop->cop_seq = seq;
4797     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4798        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4799     */
4800     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4801     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4802     if (cop->cop_hints_hash) {
4803         HINTS_REFCNT_LOCK;
4804         cop->cop_hints_hash->refcounted_he_refcnt++;
4805         HINTS_REFCNT_UNLOCK;
4806     }
4807     if (label) {
4808         Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4809                                                      
4810         PL_hints |= HINT_BLOCK_SCOPE;
4811         /* It seems that we need to defer freeing this pointer, as other parts
4812            of the grammar end up wanting to copy it after this op has been
4813            created. */
4814         SAVEFREEPV(label);
4815     }
4816
4817     if (PL_parser && PL_parser->copline == NOLINE)
4818         CopLINE_set(cop, CopLINE(PL_curcop));
4819     else {
4820         CopLINE_set(cop, PL_parser->copline);
4821         if (PL_parser)
4822             PL_parser->copline = NOLINE;
4823     }
4824 #ifdef USE_ITHREADS
4825     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4826 #else
4827     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4828 #endif
4829     CopSTASH_set(cop, PL_curstash);
4830
4831     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4832         /* this line can have a breakpoint - store the cop in IV */
4833         AV *av = CopFILEAVx(PL_curcop);
4834         if (av) {
4835             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4836             if (svp && *svp != &PL_sv_undef ) {
4837                 (void)SvIOK_on(*svp);
4838                 SvIV_set(*svp, PTR2IV(cop));
4839             }
4840         }
4841     }
4842
4843     if (flags & OPf_SPECIAL)
4844         op_null((OP*)cop);
4845     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
4846 }
4847
4848 /*
4849 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4850
4851 Constructs, checks, and returns a logical (flow control) op.  I<type>
4852 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4853 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,