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