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