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