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