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