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