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