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