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