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