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