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