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