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