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