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