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