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