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