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