Move OP prototypes from pp_proto.h to proto.h
[perl.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * A Perl program is compiled into a tree of OPs. Each op contains
26  * structural pointers (eg to its siblings and the next op in the
27  * execution sequence), a pointer to the function that would execute the
28  * op, plus any data specific to that op. For example, an OP_CONST op
29  * points to the pp_const() function and to an SV containing the constant
30  * value. When pp_const() is executed, its job is to push that SV onto the
31  * stack.
32  *
33  * OPs are mainly created by the newFOO() functions, which are mainly
34  * called from the parser (in perly.y) as the code is parsed. For example
35  * the Perl code $a + $b * $c would cause the equivalent of the following
36  * to be called (oversimplifying a bit):
37  *
38  *  newBINOP(OP_ADD, flags,
39  *      newSVREF($a),
40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41  *  )
42  *
43  * Note that during the build of miniperl, a temporary copy of this file
44  * is made, called opmini.c.
45  */
46
47 /*
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50     A bottom-up pass
51     A top-down pass
52     An execution-order pass
53
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines.  The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order.  (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
61 top level node.)
62
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again).  As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node.  But
70 it's still not the real execution order.
71
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer.  At that point, we can call
75 into peep() to do that code's portion of the 3rd pass.  It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
77 */
78
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80    get the compile time state of %^H for that block.  Storing %^H in every
81    block (or even COP) would be very expensive, so a different approach is
82    taken.  The (running) state of %^H is serialised into a tree of HE-like
83    structs.  Stores into %^H are chained onto the current leaf as a struct
84    refcounted_he * with the key and the value.  Deletes from %^H are saved
85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
86    turned back into a regular HV by walking back up the tree from that point's
87    leaf, ignoring any key you've already seen (placeholder or not), storing
88    the rest into the HV structure, then removing the placeholders. Hence
89    memory is only used to store the %^H deltas from the enclosing COP, rather
90    than the entire %^H on each COP.
91
92    To cause actions on %^H to write out the serialisation records, it has
93    magic type 'H'. This magic (itself) does nothing, but its presence causes
94    the values to gain magic type 'h', which has entries for set and clear.
95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98    it will be correctly restored when any inner compiling scope is exited.
99 */
100
101 #include "EXTERN.h"
102 #define PERL_IN_OP_C
103 #include "perl.h"
104 #include "keywords.h"
105
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              && !(right->op_flags & OPf_SPECIAL);
2243     if (ismatchop && right->op_private & OPpTARGET_MY) {
2244         right->op_targ = 0;
2245         right->op_private &= ~OPpTARGET_MY;
2246     }
2247     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2248         OP *newleft;
2249
2250         right->op_flags |= OPf_STACKED;
2251         if (rtype != OP_MATCH &&
2252             ! (rtype == OP_TRANS &&
2253                right->op_private & OPpTRANS_IDENTICAL) &&
2254             ! (rtype == OP_SUBST &&
2255                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2256             newleft = mod(left, rtype);
2257         else
2258             newleft = left;
2259         if (right->op_type == OP_TRANS)
2260             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2261         else
2262             o = prepend_elem(rtype, scalar(newleft), right);
2263         if (type == OP_NOT)
2264             return newUNOP(OP_NOT, 0, scalar(o));
2265         return o;
2266     }
2267     else
2268         return bind_match(type, left,
2269                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2270 }
2271
2272 OP *
2273 Perl_invert(pTHX_ OP *o)
2274 {
2275     if (!o)
2276         return NULL;
2277     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2278 }
2279
2280 OP *
2281 Perl_scope(pTHX_ OP *o)
2282 {
2283     dVAR;
2284     if (o) {
2285         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2286             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2287             o->op_type = OP_LEAVE;
2288             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2289         }
2290         else if (o->op_type == OP_LINESEQ) {
2291             OP *kid;
2292             o->op_type = OP_SCOPE;
2293             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2294             kid = ((LISTOP*)o)->op_first;
2295             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2296                 op_null(kid);
2297
2298                 /* The following deals with things like 'do {1 for 1}' */
2299                 kid = kid->op_sibling;
2300                 if (kid &&
2301                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2302                     op_null(kid);
2303             }
2304         }
2305         else
2306             o = newLISTOP(OP_SCOPE, 0, o, NULL);
2307     }
2308     return o;
2309 }
2310
2311 int
2312 Perl_block_start(pTHX_ int full)
2313 {
2314     dVAR;
2315     const int retval = PL_savestack_ix;
2316
2317     pad_block_start(full);
2318     SAVEHINTS();
2319     PL_hints &= ~HINT_BLOCK_SCOPE;
2320     SAVECOMPILEWARNINGS();
2321     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2322
2323     CALL_BLOCK_HOOKS(start, full);
2324
2325     return retval;
2326 }
2327
2328 OP*
2329 Perl_block_end(pTHX_ I32 floor, OP *seq)
2330 {
2331     dVAR;
2332     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2333     OP* retval = scalarseq(seq);
2334
2335     CALL_BLOCK_HOOKS(pre_end, &retval);
2336
2337     LEAVE_SCOPE(floor);
2338     CopHINTS_set(&PL_compiling, PL_hints);
2339     if (needblockscope)
2340         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2341     pad_leavemy();
2342
2343     CALL_BLOCK_HOOKS(post_end, &retval);
2344
2345     return retval;
2346 }
2347
2348 /*
2349 =head1 Compile-time scope hooks
2350
2351 =for apidoc Ao||blockhook_register
2352
2353 Register a set of hooks to be called when the Perl lexical scope changes
2354 at compile time. See L<perlguts/"Compile-time scope hooks">.
2355
2356 =cut
2357 */
2358
2359 void
2360 Perl_blockhook_register(pTHX_ BHK *hk)
2361 {
2362     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2363
2364     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2365 }
2366
2367 STATIC OP *
2368 S_newDEFSVOP(pTHX)
2369 {
2370     dVAR;
2371     const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2372     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2373         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2374     }
2375     else {
2376         OP * const o = newOP(OP_PADSV, 0);
2377         o->op_targ = offset;
2378         return o;
2379     }
2380 }
2381
2382 void
2383 Perl_newPROG(pTHX_ OP *o)
2384 {
2385     dVAR;
2386
2387     PERL_ARGS_ASSERT_NEWPROG;
2388
2389     if (PL_in_eval) {
2390         if (PL_eval_root)
2391                 return;
2392         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2393                                ((PL_in_eval & EVAL_KEEPERR)
2394                                 ? OPf_SPECIAL : 0), o);
2395         PL_eval_start = linklist(PL_eval_root);
2396         PL_eval_root->op_private |= OPpREFCOUNTED;
2397         OpREFCNT_set(PL_eval_root, 1);
2398         PL_eval_root->op_next = 0;
2399         CALL_PEEP(PL_eval_start);
2400     }
2401     else {
2402         if (o->op_type == OP_STUB) {
2403             PL_comppad_name = 0;
2404             PL_compcv = 0;
2405             S_op_destroy(aTHX_ o);
2406             return;
2407         }
2408         PL_main_root = scope(sawparens(scalarvoid(o)));
2409         PL_curcop = &PL_compiling;
2410         PL_main_start = LINKLIST(PL_main_root);
2411         PL_main_root->op_private |= OPpREFCOUNTED;
2412         OpREFCNT_set(PL_main_root, 1);
2413         PL_main_root->op_next = 0;
2414         CALL_PEEP(PL_main_start);
2415         PL_compcv = 0;
2416
2417         /* Register with debugger */
2418         if (PERLDB_INTER) {
2419             CV * const cv = get_cvs("DB::postponed", 0);
2420             if (cv) {
2421                 dSP;
2422                 PUSHMARK(SP);
2423                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2424                 PUTBACK;
2425                 call_sv(MUTABLE_SV(cv), G_DISCARD);
2426             }
2427         }
2428     }
2429 }
2430
2431 OP *
2432 Perl_localize(pTHX_ OP *o, I32 lex)
2433 {
2434     dVAR;
2435
2436     PERL_ARGS_ASSERT_LOCALIZE;
2437
2438     if (o->op_flags & OPf_PARENS)
2439 /* [perl #17376]: this appears to be premature, and results in code such as
2440    C< our(%x); > executing in list mode rather than void mode */
2441 #if 0
2442         list(o);
2443 #else
2444         NOOP;
2445 #endif
2446     else {
2447         if ( PL_parser->bufptr > PL_parser->oldbufptr
2448             && PL_parser->bufptr[-1] == ','
2449             && ckWARN(WARN_PARENTHESIS))
2450         {
2451             char *s = PL_parser->bufptr;
2452             bool sigil = FALSE;
2453
2454             /* some heuristics to detect a potential error */
2455             while (*s && (strchr(", \t\n", *s)))
2456                 s++;
2457
2458             while (1) {
2459                 if (*s && strchr("@$%*", *s) && *++s
2460                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2461                     s++;
2462                     sigil = TRUE;
2463                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2464                         s++;
2465                     while (*s && (strchr(", \t\n", *s)))
2466                         s++;
2467                 }
2468                 else
2469                     break;
2470             }
2471             if (sigil && (*s == ';' || *s == '=')) {
2472                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2473                                 "Parentheses missing around \"%s\" list",
2474                                 lex
2475                                     ? (PL_parser->in_my == KEY_our
2476                                         ? "our"
2477                                         : PL_parser->in_my == KEY_state
2478                                             ? "state"
2479                                             : "my")
2480                                     : "local");
2481             }
2482         }
2483     }
2484     if (lex)
2485         o = my(o);
2486     else
2487         o = mod(o, OP_NULL);            /* a bit kludgey */
2488     PL_parser->in_my = FALSE;
2489     PL_parser->in_my_stash = NULL;
2490     return o;
2491 }
2492
2493 OP *
2494 Perl_jmaybe(pTHX_ OP *o)
2495 {
2496     PERL_ARGS_ASSERT_JMAYBE;
2497
2498     if (o->op_type == OP_LIST) {
2499         OP * const o2
2500             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2501         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2502     }
2503     return o;
2504 }
2505
2506 static OP *
2507 S_fold_constants(pTHX_ register OP *o)
2508 {
2509     dVAR;
2510     register OP * VOL curop;
2511     OP *newop;
2512     VOL I32 type = o->op_type;
2513     SV * VOL sv = NULL;
2514     int ret = 0;
2515     I32 oldscope;
2516     OP *old_next;
2517     SV * const oldwarnhook = PL_warnhook;
2518     SV * const olddiehook  = PL_diehook;
2519     COP not_compiling;
2520     dJMPENV;
2521
2522     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2523
2524     if (PL_opargs[type] & OA_RETSCALAR)
2525         scalar(o);
2526     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2527         o->op_targ = pad_alloc(type, SVs_PADTMP);
2528
2529     /* integerize op, unless it happens to be C<-foo>.
2530      * XXX should pp_i_negate() do magic string negation instead? */
2531     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2532         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2533              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2534     {
2535         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2536     }
2537
2538     if (!(PL_opargs[type] & OA_FOLDCONST))
2539         goto nope;
2540
2541     switch (type) {
2542     case OP_NEGATE:
2543         /* XXX might want a ck_negate() for this */
2544         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2545         break;
2546     case OP_UCFIRST:
2547     case OP_LCFIRST:
2548     case OP_UC:
2549     case OP_LC:
2550     case OP_SLT:
2551     case OP_SGT:
2552     case OP_SLE:
2553     case OP_SGE:
2554     case OP_SCMP:
2555         /* XXX what about the numeric ops? */
2556         if (PL_hints & HINT_LOCALE)
2557             goto nope;
2558         break;
2559     }
2560
2561     if (PL_parser && PL_parser->error_count)
2562         goto nope;              /* Don't try to run w/ errors */
2563
2564     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2565         const OPCODE type = curop->op_type;
2566         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2567             type != OP_LIST &&
2568             type != OP_SCALAR &&
2569             type != OP_NULL &&
2570             type != OP_PUSHMARK)
2571         {
2572             goto nope;
2573         }
2574     }
2575
2576     curop = LINKLIST(o);
2577     old_next = o->op_next;
2578     o->op_next = 0;
2579     PL_op = curop;
2580
2581     oldscope = PL_scopestack_ix;
2582     create_eval_scope(G_FAKINGEVAL);
2583
2584     /* Verify that we don't need to save it:  */
2585     assert(PL_curcop == &PL_compiling);
2586     StructCopy(&PL_compiling, &not_compiling, COP);
2587     PL_curcop = &not_compiling;
2588     /* The above ensures that we run with all the correct hints of the
2589        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2590     assert(IN_PERL_RUNTIME);
2591     PL_warnhook = PERL_WARNHOOK_FATAL;
2592     PL_diehook  = NULL;
2593     JMPENV_PUSH(ret);
2594
2595     switch (ret) {
2596     case 0:
2597         CALLRUNOPS(aTHX);
2598         sv = *(PL_stack_sp--);
2599         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2600             pad_swipe(o->op_targ,  FALSE);
2601         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2602             SvREFCNT_inc_simple_void(sv);
2603             SvTEMP_off(sv);
2604         }
2605         break;
2606     case 3:
2607         /* Something tried to die.  Abandon constant folding.  */
2608         /* Pretend the error never happened.  */
2609         CLEAR_ERRSV();
2610         o->op_next = old_next;
2611         break;
2612     default:
2613         JMPENV_POP;
2614         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
2615         PL_warnhook = oldwarnhook;
2616         PL_diehook  = olddiehook;
2617         /* XXX note that this croak may fail as we've already blown away
2618          * the stack - eg any nested evals */
2619         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2620     }
2621     JMPENV_POP;
2622     PL_warnhook = oldwarnhook;
2623     PL_diehook  = olddiehook;
2624     PL_curcop = &PL_compiling;
2625
2626     if (PL_scopestack_ix > oldscope)
2627         delete_eval_scope();
2628
2629     if (ret)
2630         goto nope;
2631
2632 #ifndef PERL_MAD
2633     op_free(o);
2634 #endif
2635     assert(sv);
2636     if (type == OP_RV2GV)
2637         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2638     else
2639         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2640     op_getmad(o,newop,'f');
2641     return newop;
2642
2643  nope:
2644     return o;
2645 }
2646
2647 static OP *
2648 S_gen_constant_list(pTHX_ register OP *o)
2649 {
2650     dVAR;
2651     register OP *curop;
2652     const I32 oldtmps_floor = PL_tmps_floor;
2653
2654     list(o);
2655     if (PL_parser && PL_parser->error_count)
2656         return o;               /* Don't attempt to run with errors */
2657
2658     PL_op = curop = LINKLIST(o);
2659     o->op_next = 0;
2660     CALL_PEEP(curop);
2661     pp_pushmark();
2662     CALLRUNOPS(aTHX);
2663     PL_op = curop;
2664     assert (!(curop->op_flags & OPf_SPECIAL));
2665     assert(curop->op_type == OP_RANGE);
2666     pp_anonlist();
2667     PL_tmps_floor = oldtmps_floor;
2668
2669     o->op_type = OP_RV2AV;
2670     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2671     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2672     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2673     o->op_opt = 0;              /* needs to be revisited in rpeep() */
2674     curop = ((UNOP*)o)->op_first;
2675     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2676 #ifdef PERL_MAD
2677     op_getmad(curop,o,'O');
2678 #else
2679     op_free(curop);
2680 #endif
2681     linklist(o);
2682     return list(o);
2683 }
2684
2685 OP *
2686 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2687 {
2688     dVAR;
2689     if (!o || o->op_type != OP_LIST)
2690         o = newLISTOP(OP_LIST, 0, o, NULL);
2691     else
2692         o->op_flags &= ~OPf_WANT;
2693
2694     if (!(PL_opargs[type] & OA_MARK))
2695         op_null(cLISTOPo->op_first);
2696
2697     o->op_type = (OPCODE)type;
2698     o->op_ppaddr = PL_ppaddr[type];
2699     o->op_flags |= flags;
2700
2701     o = CHECKOP(type, o);
2702     if (o->op_type != (unsigned)type)
2703         return o;
2704
2705     return fold_constants(o);
2706 }
2707
2708 /* List constructors */
2709
2710 OP *
2711 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2712 {
2713     if (!first)
2714         return last;
2715
2716     if (!last)
2717         return first;
2718
2719     if (first->op_type != (unsigned)type
2720         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2721     {
2722         return newLISTOP(type, 0, first, last);
2723     }
2724
2725     if (first->op_flags & OPf_KIDS)
2726         ((LISTOP*)first)->op_last->op_sibling = last;
2727     else {
2728         first->op_flags |= OPf_KIDS;
2729         ((LISTOP*)first)->op_first = last;
2730     }
2731     ((LISTOP*)first)->op_last = last;
2732     return first;
2733 }
2734
2735 OP *
2736 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2737 {
2738     if (!first)
2739         return (OP*)last;
2740
2741     if (!last)
2742         return (OP*)first;
2743
2744     if (first->op_type != (unsigned)type)
2745         return prepend_elem(type, (OP*)first, (OP*)last);
2746
2747     if (last->op_type != (unsigned)type)
2748         return append_elem(type, (OP*)first, (OP*)last);
2749
2750     first->op_last->op_sibling = last->op_first;
2751     first->op_last = last->op_last;
2752     first->op_flags |= (last->op_flags & OPf_KIDS);
2753
2754 #ifdef PERL_MAD
2755     if (last->op_first && first->op_madprop) {
2756         MADPROP *mp = last->op_first->op_madprop;
2757         if (mp) {
2758             while (mp->mad_next)
2759                 mp = mp->mad_next;
2760             mp->mad_next = first->op_madprop;
2761         }
2762         else {
2763             last->op_first->op_madprop = first->op_madprop;
2764         }
2765     }
2766     first->op_madprop = last->op_madprop;
2767     last->op_madprop = 0;
2768 #endif
2769
2770     S_op_destroy(aTHX_ (OP*)last);
2771
2772     return (OP*)first;
2773 }
2774
2775 OP *
2776 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2777 {
2778     if (!first)
2779         return last;
2780
2781     if (!last)
2782         return first;
2783
2784     if (last->op_type == (unsigned)type) {
2785         if (type == OP_LIST) {  /* already a PUSHMARK there */
2786             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2787             ((LISTOP*)last)->op_first->op_sibling = first;
2788             if (!(first->op_flags & OPf_PARENS))
2789                 last->op_flags &= ~OPf_PARENS;
2790         }
2791         else {
2792             if (!(last->op_flags & OPf_KIDS)) {
2793                 ((LISTOP*)last)->op_last = first;
2794                 last->op_flags |= OPf_KIDS;
2795             }
2796             first->op_sibling = ((LISTOP*)last)->op_first;
2797             ((LISTOP*)last)->op_first = first;
2798         }
2799         last->op_flags |= OPf_KIDS;
2800         return last;
2801     }
2802
2803     return newLISTOP(type, 0, first, last);
2804 }
2805
2806 /* Constructors */
2807
2808 #ifdef PERL_MAD
2809  
2810 TOKEN *
2811 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2812 {
2813     TOKEN *tk;
2814     Newxz(tk, 1, TOKEN);
2815     tk->tk_type = (OPCODE)optype;
2816     tk->tk_type = 12345;
2817     tk->tk_lval = lval;
2818     tk->tk_mad = madprop;
2819     return tk;
2820 }
2821
2822 void
2823 Perl_token_free(pTHX_ TOKEN* tk)
2824 {
2825     PERL_ARGS_ASSERT_TOKEN_FREE;
2826
2827     if (tk->tk_type != 12345)
2828         return;
2829     mad_free(tk->tk_mad);
2830     Safefree(tk);
2831 }
2832
2833 void
2834 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2835 {
2836     MADPROP* mp;
2837     MADPROP* tm;
2838
2839     PERL_ARGS_ASSERT_TOKEN_GETMAD;
2840
2841     if (tk->tk_type != 12345) {
2842         Perl_warner(aTHX_ packWARN(WARN_MISC),
2843              "Invalid TOKEN object ignored");
2844         return;
2845     }
2846     tm = tk->tk_mad;
2847     if (!tm)
2848         return;
2849
2850     /* faked up qw list? */
2851     if (slot == '(' &&
2852         tm->mad_type == MAD_SV &&
2853         SvPVX((SV *)tm->mad_val)[0] == 'q')
2854             slot = 'x';
2855
2856     if (o) {
2857         mp = o->op_madprop;
2858         if (mp) {
2859             for (;;) {
2860                 /* pretend constant fold didn't happen? */
2861                 if (mp->mad_key == 'f' &&
2862                     (o->op_type == OP_CONST ||
2863                      o->op_type == OP_GV) )
2864                 {
2865                     token_getmad(tk,(OP*)mp->mad_val,slot);
2866                     return;
2867                 }
2868                 if (!mp->mad_next)
2869                     break;
2870                 mp = mp->mad_next;
2871             }
2872             mp->mad_next = tm;
2873             mp = mp->mad_next;
2874         }
2875         else {
2876             o->op_madprop = tm;
2877             mp = o->op_madprop;
2878         }
2879         if (mp->mad_key == 'X')
2880             mp->mad_key = slot; /* just change the first one */
2881
2882         tk->tk_mad = 0;
2883     }
2884     else
2885         mad_free(tm);
2886     Safefree(tk);
2887 }
2888
2889 void
2890 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2891 {
2892     MADPROP* mp;
2893     if (!from)
2894         return;
2895     if (o) {
2896         mp = o->op_madprop;
2897         if (mp) {
2898             for (;;) {
2899                 /* pretend constant fold didn't happen? */
2900                 if (mp->mad_key == 'f' &&
2901                     (o->op_type == OP_CONST ||
2902                      o->op_type == OP_GV) )
2903                 {
2904                     op_getmad(from,(OP*)mp->mad_val,slot);
2905                     return;
2906                 }
2907                 if (!mp->mad_next)
2908                     break;
2909                 mp = mp->mad_next;
2910             }
2911             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2912         }
2913         else {
2914             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2915         }
2916     }
2917 }
2918
2919 void
2920 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2921 {
2922     MADPROP* mp;
2923     if (!from)
2924         return;
2925     if (o) {
2926         mp = o->op_madprop;
2927         if (mp) {
2928             for (;;) {
2929                 /* pretend constant fold didn't happen? */
2930                 if (mp->mad_key == 'f' &&
2931                     (o->op_type == OP_CONST ||
2932                      o->op_type == OP_GV) )
2933                 {
2934                     op_getmad(from,(OP*)mp->mad_val,slot);
2935                     return;
2936                 }
2937                 if (!mp->mad_next)
2938                     break;
2939                 mp = mp->mad_next;
2940             }
2941             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2942         }
2943         else {
2944             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2945         }
2946     }
2947     else {
2948         PerlIO_printf(PerlIO_stderr(),
2949                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2950         op_free(from);
2951     }
2952 }
2953
2954 void
2955 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2956 {
2957     MADPROP* tm;
2958     if (!mp || !o)
2959         return;
2960     if (slot)
2961         mp->mad_key = slot;
2962     tm = o->op_madprop;
2963     o->op_madprop = mp;
2964     for (;;) {
2965         if (!mp->mad_next)
2966             break;
2967         mp = mp->mad_next;
2968     }
2969     mp->mad_next = tm;
2970 }
2971
2972 void
2973 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2974 {
2975     if (!o)
2976         return;
2977     addmad(tm, &(o->op_madprop), slot);
2978 }
2979
2980 void
2981 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2982 {
2983     MADPROP* mp;
2984     if (!tm || !root)
2985         return;
2986     if (slot)
2987         tm->mad_key = slot;
2988     mp = *root;
2989     if (!mp) {
2990         *root = tm;
2991         return;
2992     }
2993     for (;;) {
2994         if (!mp->mad_next)
2995             break;
2996         mp = mp->mad_next;
2997     }
2998     mp->mad_next = tm;
2999 }
3000
3001 MADPROP *
3002 Perl_newMADsv(pTHX_ char key, SV* sv)
3003 {
3004     PERL_ARGS_ASSERT_NEWMADSV;
3005
3006     return newMADPROP(key, MAD_SV, sv, 0);
3007 }
3008
3009 MADPROP *
3010 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3011 {
3012     MADPROP *mp;
3013     Newxz(mp, 1, MADPROP);
3014     mp->mad_next = 0;
3015     mp->mad_key = key;
3016     mp->mad_vlen = vlen;
3017     mp->mad_type = type;
3018     mp->mad_val = val;
3019 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
3020     return mp;
3021 }
3022
3023 void
3024 Perl_mad_free(pTHX_ MADPROP* mp)
3025 {
3026 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3027     if (!mp)
3028         return;
3029     if (mp->mad_next)
3030         mad_free(mp->mad_next);
3031 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3032         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3033     switch (mp->mad_type) {
3034     case MAD_NULL:
3035         break;
3036     case MAD_PV:
3037         Safefree((char*)mp->mad_val);
3038         break;
3039     case MAD_OP:
3040         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
3041             op_free((OP*)mp->mad_val);
3042         break;
3043     case MAD_SV:
3044         sv_free(MUTABLE_SV(mp->mad_val));
3045         break;
3046     default:
3047         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3048         break;
3049     }
3050     Safefree(mp);
3051 }
3052
3053 #endif
3054
3055 /*
3056 =head1 Optree construction
3057
3058 =for apidoc Am|OP *|newNULLLIST
3059
3060 Constructs, checks, and returns a new C<stub> op, which represents an
3061 empty list expression.
3062
3063 =cut
3064 */
3065
3066 OP *
3067 Perl_newNULLLIST(pTHX)
3068 {
3069     return newOP(OP_STUB, 0);
3070 }
3071
3072 static OP *
3073 S_force_list(pTHX_ OP *o)
3074 {
3075     if (!o || o->op_type != OP_LIST)
3076         o = newLISTOP(OP_LIST, 0, o, NULL);
3077     op_null(o);
3078     return o;
3079 }
3080
3081 /*
3082 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3083
3084 Constructs, checks, and returns an op of any list type.  I<type> is
3085 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3086 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
3087 supply up to two ops to be direct children of the list op; they are
3088 consumed by this function and become part of the constructed op tree.
3089
3090 =cut
3091 */
3092
3093 OP *
3094 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3095 {
3096     dVAR;
3097     LISTOP *listop;
3098
3099     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3100
3101     NewOp(1101, listop, 1, LISTOP);
3102
3103     listop->op_type = (OPCODE)type;
3104     listop->op_ppaddr = PL_ppaddr[type];
3105     if (first || last)
3106         flags |= OPf_KIDS;
3107     listop->op_flags = (U8)flags;
3108
3109     if (!last && first)
3110         last = first;
3111     else if (!first && last)
3112         first = last;
3113     else if (first)
3114         first->op_sibling = last;
3115     listop->op_first = first;
3116     listop->op_last = last;
3117     if (type == OP_LIST) {
3118         OP* const pushop = newOP(OP_PUSHMARK, 0);
3119         pushop->op_sibling = first;
3120         listop->op_first = pushop;
3121         listop->op_flags |= OPf_KIDS;
3122         if (!last)
3123             listop->op_last = pushop;
3124     }
3125
3126     return CHECKOP(type, listop);
3127 }
3128
3129 /*
3130 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3131
3132 Constructs, checks, and returns an op of any base type (any type that
3133 has no extra fields).  I<type> is the opcode.  I<flags> gives the
3134 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3135 of C<op_private>.
3136
3137 =cut
3138 */
3139
3140 OP *
3141 Perl_newOP(pTHX_ I32 type, I32 flags)
3142 {
3143     dVAR;
3144     OP *o;
3145
3146     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3147         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3148         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3149         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3150
3151     NewOp(1101, o, 1, OP);
3152     o->op_type = (OPCODE)type;
3153     o->op_ppaddr = PL_ppaddr[type];
3154     o->op_flags = (U8)flags;
3155     o->op_latefree = 0;
3156     o->op_latefreed = 0;
3157     o->op_attached = 0;
3158
3159     o->op_next = o;
3160     o->op_private = (U8)(0 | (flags >> 8));
3161     if (PL_opargs[type] & OA_RETSCALAR)
3162         scalar(o);
3163     if (PL_opargs[type] & OA_TARGET)
3164         o->op_targ = pad_alloc(type, SVs_PADTMP);
3165     return CHECKOP(type, o);
3166 }
3167
3168 /*
3169 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3170
3171 Constructs, checks, and returns an op of any unary type.  I<type> is
3172 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
3173 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3174 bits, the eight bits of C<op_private>, except that the bit with value 1
3175 is automatically set.  I<first> supplies an optional op to be the direct
3176 child of the unary op; it is consumed by this function and become part
3177 of the constructed op tree.
3178
3179 =cut
3180 */
3181
3182 OP *
3183 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3184 {
3185     dVAR;
3186     UNOP *unop;
3187
3188     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3189         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3190         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3191         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3192         || type == OP_SASSIGN
3193         || type == OP_ENTERTRY
3194         || type == OP_NULL );
3195
3196     if (!first)
3197         first = newOP(OP_STUB, 0);
3198     if (PL_opargs[type] & OA_MARK)
3199         first = force_list(first);
3200
3201     NewOp(1101, unop, 1, UNOP);
3202     unop->op_type = (OPCODE)type;
3203     unop->op_ppaddr = PL_ppaddr[type];
3204     unop->op_first = first;
3205     unop->op_flags = (U8)(flags | OPf_KIDS);
3206     unop->op_private = (U8)(1 | (flags >> 8));
3207     unop = (UNOP*) CHECKOP(type, unop);
3208     if (unop->op_next)
3209         return (OP*)unop;
3210
3211     return fold_constants((OP *) unop);
3212 }
3213
3214 /*
3215 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3216
3217 Constructs, checks, and returns an op of any binary type.  I<type>
3218 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
3219 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3220 the eight bits of C<op_private>, except that the bit with value 1 or
3221 2 is automatically set as required.  I<first> and I<last> supply up to
3222 two ops to be the direct children of the binary op; they are consumed
3223 by this function and become part of the constructed op tree.
3224
3225 =cut
3226 */
3227
3228 OP *
3229 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3230 {
3231     dVAR;
3232     BINOP *binop;
3233
3234     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3235         || type == OP_SASSIGN || type == OP_NULL );
3236
3237     NewOp(1101, binop, 1, BINOP);
3238
3239     if (!first)
3240         first = newOP(OP_NULL, 0);
3241
3242     binop->op_type = (OPCODE)type;
3243     binop->op_ppaddr = PL_ppaddr[type];
3244     binop->op_first = first;
3245     binop->op_flags = (U8)(flags | OPf_KIDS);
3246     if (!last) {
3247         last = first;
3248         binop->op_private = (U8)(1 | (flags >> 8));
3249     }
3250     else {
3251         binop->op_private = (U8)(2 | (flags >> 8));
3252         first->op_sibling = last;
3253     }
3254
3255     binop = (BINOP*)CHECKOP(type, binop);
3256     if (binop->op_next || binop->op_type != (OPCODE)type)
3257         return (OP*)binop;
3258
3259     binop->op_last = binop->op_first->op_sibling;
3260
3261     return fold_constants((OP *)binop);
3262 }
3263
3264 static int uvcompare(const void *a, const void *b)
3265     __attribute__nonnull__(1)
3266     __attribute__nonnull__(2)
3267     __attribute__pure__;
3268 static int uvcompare(const void *a, const void *b)
3269 {
3270     if (*((const UV *)a) < (*(const UV *)b))
3271         return -1;
3272     if (*((const UV *)a) > (*(const UV *)b))
3273         return 1;
3274     if (*((const UV *)a+1) < (*(const UV *)b+1))
3275         return -1;
3276     if (*((const UV *)a+1) > (*(const UV *)b+1))
3277         return 1;
3278     return 0;
3279 }
3280
3281 static OP *
3282 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3283 {
3284     dVAR;
3285     SV * const tstr = ((SVOP*)expr)->op_sv;
3286     SV * const rstr =
3287 #ifdef PERL_MAD
3288                         (repl->op_type == OP_NULL)
3289                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3290 #endif
3291                               ((SVOP*)repl)->op_sv;
3292     STRLEN tlen;
3293     STRLEN rlen;
3294     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3295     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3296     register I32 i;
3297     register I32 j;
3298     I32 grows = 0;
3299     register short *tbl;
3300
3301     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3302     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3303     I32 del              = o->op_private & OPpTRANS_DELETE;
3304     SV* swash;
3305
3306     PERL_ARGS_ASSERT_PMTRANS;
3307
3308     PL_hints |= HINT_BLOCK_SCOPE;
3309
3310     if (SvUTF8(tstr))
3311         o->op_private |= OPpTRANS_FROM_UTF;
3312
3313     if (SvUTF8(rstr))
3314         o->op_private |= OPpTRANS_TO_UTF;
3315
3316     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3317         SV* const listsv = newSVpvs("# comment\n");
3318         SV* transv = NULL;
3319         const U8* tend = t + tlen;
3320         const U8* rend = r + rlen;
3321         STRLEN ulen;
3322         UV tfirst = 1;
3323         UV tlast = 0;
3324         IV tdiff;
3325         UV rfirst = 1;
3326         UV rlast = 0;
3327         IV rdiff;
3328         IV diff;
3329         I32 none = 0;
3330         U32 max = 0;
3331         I32 bits;
3332         I32 havefinal = 0;
3333         U32 final = 0;
3334         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3335         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3336         U8* tsave = NULL;
3337         U8* rsave = NULL;
3338         const U32 flags = UTF8_ALLOW_DEFAULT;
3339
3340         if (!from_utf) {
3341             STRLEN len = tlen;
3342             t = tsave = bytes_to_utf8(t, &len);
3343             tend = t + len;
3344         }
3345         if (!to_utf && rlen) {
3346             STRLEN len = rlen;
3347             r = rsave = bytes_to_utf8(r, &len);
3348             rend = r + len;
3349         }
3350
3351 /* There are several snags with this code on EBCDIC:
3352    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3353    2. scan_const() in toke.c has encoded chars in native encoding which makes
3354       ranges at least in EBCDIC 0..255 range the bottom odd.
3355 */
3356
3357         if (complement) {
3358             U8 tmpbuf[UTF8_MAXBYTES+1];
3359             UV *cp;
3360             UV nextmin = 0;
3361             Newx(cp, 2*tlen, UV);
3362             i = 0;
3363             transv = newSVpvs("");
3364             while (t < tend) {
3365                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3366                 t += ulen;
3367                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3368                     t++;
3369                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3370                     t += ulen;
3371                 }
3372                 else {
3373                  cp[2*i+1] = cp[2*i];
3374                 }
3375                 i++;
3376             }
3377             qsort(cp, i, 2*sizeof(UV), uvcompare);
3378             for (j = 0; j < i; j++) {
3379                 UV  val = cp[2*j];
3380                 diff = val - nextmin;
3381                 if (diff > 0) {
3382                     t = uvuni_to_utf8(tmpbuf,nextmin);
3383                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3384                     if (diff > 1) {
3385                         U8  range_mark = UTF_TO_NATIVE(0xff);
3386                         t = uvuni_to_utf8(tmpbuf, val - 1);
3387                         sv_catpvn(transv, (char *)&range_mark, 1);
3388                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3389                     }
3390                 }
3391                 val = cp[2*j+1];
3392                 if (val >= nextmin)
3393                     nextmin = val + 1;
3394             }
3395             t = uvuni_to_utf8(tmpbuf,nextmin);
3396             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3397             {
3398                 U8 range_mark = UTF_TO_NATIVE(0xff);
3399                 sv_catpvn(transv, (char *)&range_mark, 1);
3400             }
3401             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3402                                     UNICODE_ALLOW_SUPER);
3403             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3404             t = (const U8*)SvPVX_const(transv);
3405             tlen = SvCUR(transv);
3406             tend = t + tlen;
3407             Safefree(cp);
3408         }
3409         else if (!rlen && !del) {
3410             r = t; rlen = tlen; rend = tend;
3411         }
3412         if (!squash) {
3413                 if ((!rlen && !del) || t == r ||
3414                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3415                 {
3416                     o->op_private |= OPpTRANS_IDENTICAL;
3417                 }
3418         }
3419
3420         while (t < tend || tfirst <= tlast) {
3421             /* see if we need more "t" chars */
3422             if (tfirst > tlast) {
3423                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3424                 t += ulen;
3425                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3426                     t++;
3427                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3428                     t += ulen;
3429                 }
3430                 else
3431                     tlast = tfirst;
3432             }
3433
3434             /* now see if we need more "r" chars */
3435             if (rfirst > rlast) {
3436                 if (r < rend) {
3437                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3438                     r += ulen;
3439                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3440                         r++;
3441                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3442                         r += ulen;
3443                     }
3444                     else
3445                         rlast = rfirst;
3446                 }
3447                 else {
3448                     if (!havefinal++)
3449                         final = rlast;
3450                     rfirst = rlast = 0xffffffff;
3451                 }
3452             }
3453
3454             /* now see which range will peter our first, if either. */
3455             tdiff = tlast - tfirst;
3456             rdiff = rlast - rfirst;
3457
3458             if (tdiff <= rdiff)
3459                 diff = tdiff;
3460             else
3461                 diff = rdiff;
3462
3463             if (rfirst == 0xffffffff) {
3464                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3465                 if (diff > 0)
3466                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3467                                    (long)tfirst, (long)tlast);
3468                 else
3469                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3470             }
3471             else {
3472                 if (diff > 0)
3473                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3474                                    (long)tfirst, (long)(tfirst + diff),
3475                                    (long)rfirst);
3476                 else
3477                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3478                                    (long)tfirst, (long)rfirst);
3479
3480                 if (rfirst + diff > max)
3481                     max = rfirst + diff;
3482                 if (!grows)
3483                     grows = (tfirst < rfirst &&
3484                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3485                 rfirst += diff + 1;
3486             }
3487             tfirst += diff + 1;
3488         }
3489
3490         none = ++max;
3491         if (del)
3492             del = ++max;
3493
3494         if (max > 0xffff)
3495             bits = 32;
3496         else if (max > 0xff)
3497             bits = 16;
3498         else
3499             bits = 8;
3500
3501         PerlMemShared_free(cPVOPo->op_pv);
3502         cPVOPo->op_pv = NULL;
3503
3504         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3505 #ifdef USE_ITHREADS
3506         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3507         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3508         PAD_SETSV(cPADOPo->op_padix, swash);
3509         SvPADTMP_on(swash);
3510         SvREADONLY_on(swash);
3511 #else
3512         cSVOPo->op_sv = swash;
3513 #endif
3514         SvREFCNT_dec(listsv);
3515         SvREFCNT_dec(transv);
3516
3517         if (!del && havefinal && rlen)
3518             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3519                            newSVuv((UV)final), 0);
3520
3521         if (grows)
3522             o->op_private |= OPpTRANS_GROWS;
3523
3524         Safefree(tsave);
3525         Safefree(rsave);
3526
3527 #ifdef PERL_MAD
3528         op_getmad(expr,o,'e');
3529         op_getmad(repl,o,'r');
3530 #else
3531         op_free(expr);
3532         op_free(repl);
3533 #endif
3534         return o;
3535     }
3536
3537     tbl = (short*)cPVOPo->op_pv;
3538     if (complement) {
3539         Zero(tbl, 256, short);
3540         for (i = 0; i < (I32)tlen; i++)
3541             tbl[t[i]] = -1;
3542         for (i = 0, j = 0; i < 256; i++) {
3543             if (!tbl[i]) {
3544                 if (j >= (I32)rlen) {
3545                     if (del)
3546                         tbl[i] = -2;
3547                     else if (rlen)
3548                         tbl[i] = r[j-1];
3549                     else
3550                         tbl[i] = (short)i;
3551                 }
3552                 else {
3553                     if (i < 128 && r[j] >= 128)
3554                         grows = 1;
3555                     tbl[i] = r[j++];
3556                 }
3557             }
3558         }
3559         if (!del) {
3560             if (!rlen) {
3561                 j = rlen;
3562                 if (!squash)
3563                     o->op_private |= OPpTRANS_IDENTICAL;
3564             }
3565             else if (j >= (I32)rlen)
3566                 j = rlen - 1;
3567             else {
3568                 tbl = 
3569                     (short *)
3570                     PerlMemShared_realloc(tbl,
3571                                           (0x101+rlen-j) * sizeof(short));
3572                 cPVOPo->op_pv = (char*)tbl;
3573             }
3574             tbl[0x100] = (short)(rlen - j);
3575             for (i=0; i < (I32)rlen - j; i++)
3576                 tbl[0x101+i] = r[j+i];
3577         }
3578     }
3579     else {
3580         if (!rlen && !del) {
3581             r = t; rlen = tlen;
3582             if (!squash)
3583                 o->op_private |= OPpTRANS_IDENTICAL;
3584         }
3585         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3586             o->op_private |= OPpTRANS_IDENTICAL;
3587         }
3588         for (i = 0; i < 256; i++)
3589             tbl[i] = -1;
3590         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3591             if (j >= (I32)rlen) {
3592                 if (del) {
3593                     if (tbl[t[i]] == -1)
3594                         tbl[t[i]] = -2;
3595                     continue;
3596                 }
3597                 --j;
3598             }
3599             if (tbl[t[i]] == -1) {
3600                 if (t[i] < 128 && r[j] >= 128)
3601                     grows = 1;
3602                 tbl[t[i]] = r[j];
3603             }
3604         }
3605     }
3606
3607     if(del && rlen == tlen) {
3608         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
3609     } else if(rlen > tlen) {
3610         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3611     }
3612
3613     if (grows)
3614         o->op_private |= OPpTRANS_GROWS;
3615 #ifdef PERL_MAD
3616     op_getmad(expr,o,'e');
3617     op_getmad(repl,o,'r');
3618 #else
3619     op_free(expr);
3620     op_free(repl);
3621 #endif
3622
3623     return o;
3624 }
3625
3626 /*
3627 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
3628
3629 Constructs, checks, and returns an op of any pattern matching type.
3630 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
3631 and, shifted up eight bits, the eight bits of C<op_private>.
3632
3633 =cut
3634 */
3635
3636 OP *
3637 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3638 {
3639     dVAR;
3640     PMOP *pmop;
3641
3642     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
3643
3644     NewOp(1101, pmop, 1, PMOP);
3645     pmop->op_type = (OPCODE)type;
3646     pmop->op_ppaddr = PL_ppaddr[type];
3647     pmop->op_flags = (U8)flags;
3648     pmop->op_private = (U8)(0 | (flags >> 8));
3649
3650     if (PL_hints & HINT_RE_TAINT)
3651         pmop->op_pmflags |= PMf_RETAINT;
3652     if (PL_hints & HINT_LOCALE) {
3653         pmop->op_pmflags |= PMf_LOCALE;
3654     }
3655     else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
3656         pmop->op_pmflags |= RXf_PMf_UNICODE;
3657     }
3658
3659
3660 #ifdef USE_ITHREADS
3661     assert(SvPOK(PL_regex_pad[0]));
3662     if (SvCUR(PL_regex_pad[0])) {
3663         /* Pop off the "packed" IV from the end.  */
3664         SV *const repointer_list = PL_regex_pad[0];
3665         const char *p = SvEND(repointer_list) - sizeof(IV);
3666         const IV offset = *((IV*)p);
3667
3668         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3669
3670         SvEND_set(repointer_list, p);
3671
3672         pmop->op_pmoffset = offset;
3673         /* This slot should be free, so assert this:  */
3674         assert(PL_regex_pad[offset] == &PL_sv_undef);
3675     } else {
3676         SV * const repointer = &PL_sv_undef;
3677         av_push(PL_regex_padav, repointer);
3678         pmop->op_pmoffset = av_len(PL_regex_padav);
3679         PL_regex_pad = AvARRAY(PL_regex_padav);
3680     }
3681 #endif
3682
3683     return CHECKOP(type, pmop);
3684 }
3685
3686 /* Given some sort of match op o, and an expression expr containing a
3687  * pattern, either compile expr into a regex and attach it to o (if it's
3688  * constant), or convert expr into a runtime regcomp op sequence (if it's
3689  * not)
3690  *
3691  * isreg indicates that the pattern is part of a regex construct, eg
3692  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3693  * split "pattern", which aren't. In the former case, expr will be a list
3694  * if the pattern contains more than one term (eg /a$b/) or if it contains
3695  * a replacement, ie s/// or tr///.
3696  */
3697
3698 OP *
3699 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3700 {
3701     dVAR;
3702     PMOP *pm;
3703     LOGOP *rcop;
3704     I32 repl_has_vars = 0;
3705     OP* repl = NULL;
3706     bool reglist;
3707
3708     PERL_ARGS_ASSERT_PMRUNTIME;
3709
3710     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3711         /* last element in list is the replacement; pop it */
3712         OP* kid;
3713         repl = cLISTOPx(expr)->op_last;
3714         kid = cLISTOPx(expr)->op_first;
3715         while (kid->op_sibling != repl)
3716             kid = kid->op_sibling;
3717         kid->op_sibling = NULL;
3718         cLISTOPx(expr)->op_last = kid;
3719     }
3720
3721     if (isreg && expr->op_type == OP_LIST &&
3722         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3723     {
3724         /* convert single element list to element */
3725         OP* const oe = expr;
3726         expr = cLISTOPx(oe)->op_first->op_sibling;
3727         cLISTOPx(oe)->op_first->op_sibling = NULL;
3728         cLISTOPx(oe)->op_last = NULL;
3729         op_free(oe);
3730     }
3731
3732     if (o->op_type == OP_TRANS) {
3733         return pmtrans(o, expr, repl);
3734     }
3735
3736     reglist = isreg && expr->op_type == OP_LIST;
3737     if (reglist)
3738         op_null(expr);
3739
3740     PL_hints |= HINT_BLOCK_SCOPE;
3741     pm = (PMOP*)o;
3742
3743     if (expr->op_type == OP_CONST) {
3744         SV *pat = ((SVOP*)expr)->op_sv;
3745         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3746
3747         if (o->op_flags & OPf_SPECIAL)
3748             pm_flags |= RXf_SPLIT;
3749
3750         if (DO_UTF8(pat)) {
3751             assert (SvUTF8(pat));
3752         } else if (SvUTF8(pat)) {
3753             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3754                trapped in use 'bytes'?  */
3755             /* Make a copy of the octet sequence, but without the flag on, as
3756                the compiler now honours the SvUTF8 flag on pat.  */
3757             STRLEN len;
3758             const char *const p = SvPV(pat, len);
3759             pat = newSVpvn_flags(p, len, SVs_TEMP);
3760         }
3761
3762         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3763
3764 #ifdef PERL_MAD
3765         op_getmad(expr,(OP*)pm,'e');
3766 #else
3767         op_free(expr);
3768 #endif
3769     }
3770     else {
3771         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3772             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3773                             ? OP_REGCRESET
3774                             : OP_REGCMAYBE),0,expr);
3775
3776         NewOp(1101, rcop, 1, LOGOP);
3777         rcop->op_type = OP_REGCOMP;
3778         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3779         rcop->op_first = scalar(expr);
3780         rcop->op_flags |= OPf_KIDS
3781                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3782                             | (reglist ? OPf_STACKED : 0);
3783         rcop->op_private = 1;
3784         rcop->op_other = o;
3785         if (reglist)
3786             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3787
3788         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3789         PL_cv_has_eval = 1;
3790
3791         /* establish postfix order */
3792         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3793             LINKLIST(expr);
3794             rcop->op_next = expr;
3795             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3796         }
3797         else {
3798             rcop->op_next = LINKLIST(expr);
3799             expr->op_next = (OP*)rcop;
3800         }
3801
3802         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3803     }
3804
3805     if (repl) {
3806         OP *curop;
3807         if (pm->op_pmflags & PMf_EVAL) {
3808             curop = NULL;
3809             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3810                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3811         }
3812         else if (repl->op_type == OP_CONST)
3813             curop = repl;
3814         else {
3815             OP *lastop = NULL;
3816             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3817                 if (curop->op_type == OP_SCOPE
3818                         || curop->op_type == OP_LEAVE
3819                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3820                     if (curop->op_type == OP_GV) {
3821                         GV * const gv = cGVOPx_gv(curop);
3822                         repl_has_vars = 1;
3823                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3824                             break;
3825                     }
3826                     else if (curop->op_type == OP_RV2CV)
3827                         break;
3828                     else if (curop->op_type == OP_RV2SV ||
3829                              curop->op_type == OP_RV2AV ||
3830                              curop->op_type == OP_RV2HV ||
3831                              curop->op_type == OP_RV2GV) {
3832                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3833                             break;
3834                     }
3835                     else if (curop->op_type == OP_PADSV ||
3836                              curop->op_type == OP_PADAV ||
3837                              curop->op_type == OP_PADHV ||
3838                              curop->op_type == OP_PADANY)
3839                     {
3840                         repl_has_vars = 1;
3841                     }
3842                     else if (curop->op_type == OP_PUSHRE)
3843                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3844                     else
3845                         break;
3846                 }
3847                 lastop = curop;
3848             }
3849         }
3850         if (curop == repl
3851             && !(repl_has_vars
3852                  && (!PM_GETRE(pm)
3853                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3854         {
3855             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3856             prepend_elem(o->op_type, scalar(repl), o);
3857         }
3858         else {
3859             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3860                 pm->op_pmflags |= PMf_MAYBE_CONST;
3861             }
3862             NewOp(1101, rcop, 1, LOGOP);
3863             rcop->op_type = OP_SUBSTCONT;
3864             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3865             rcop->op_first = scalar(repl);
3866             rcop->op_flags |= OPf_KIDS;
3867             rcop->op_private = 1;
3868             rcop->op_other = o;
3869
3870             /* establish postfix order */
3871             rcop->op_next = LINKLIST(repl);
3872             repl->op_next = (OP*)rcop;
3873
3874             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3875             assert(!(pm->op_pmflags & PMf_ONCE));
3876             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3877             rcop->op_next = 0;
3878         }
3879     }
3880
3881     return (OP*)pm;
3882 }
3883
3884 /*
3885 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
3886
3887 Constructs, checks, and returns an op of any type that involves an
3888 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
3889 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
3890 takes ownership of one reference to it.
3891
3892 =cut
3893 */
3894
3895 OP *
3896 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3897 {
3898     dVAR;
3899     SVOP *svop;
3900
3901     PERL_ARGS_ASSERT_NEWSVOP;
3902
3903     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3904         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3905         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3906
3907     NewOp(1101, svop, 1, SVOP);
3908     svop->op_type = (OPCODE)type;
3909     svop->op_ppaddr = PL_ppaddr[type];
3910     svop->op_sv = sv;
3911     svop->op_next = (OP*)svop;
3912     svop->op_flags = (U8)flags;
3913     if (PL_opargs[type] & OA_RETSCALAR)
3914         scalar((OP*)svop);
3915     if (PL_opargs[type] & OA_TARGET)
3916         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3917     return CHECKOP(type, svop);
3918 }
3919
3920 #ifdef USE_ITHREADS
3921
3922 /*
3923 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
3924
3925 Constructs, checks, and returns an op of any type that involves a
3926 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
3927 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
3928 is populated with I<sv>; this function takes ownership of one reference
3929 to it.
3930
3931 This function only exists if Perl has been compiled to use ithreads.
3932
3933 =cut
3934 */
3935
3936 OP *
3937 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3938 {
3939     dVAR;
3940     PADOP *padop;
3941
3942     PERL_ARGS_ASSERT_NEWPADOP;
3943
3944     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
3945         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
3946         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
3947
3948     NewOp(1101, padop, 1, PADOP);
3949     padop->op_type = (OPCODE)type;
3950     padop->op_ppaddr = PL_ppaddr[type];
3951     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3952     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3953     PAD_SETSV(padop->op_padix, sv);
3954     assert(sv);
3955     SvPADTMP_on(sv);
3956     padop->op_next = (OP*)padop;
3957     padop->op_flags = (U8)flags;
3958     if (PL_opargs[type] & OA_RETSCALAR)
3959         scalar((OP*)padop);
3960     if (PL_opargs[type] & OA_TARGET)
3961         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3962     return CHECKOP(type, padop);
3963 }
3964
3965 #endif /* !USE_ITHREADS */
3966
3967 /*
3968 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
3969
3970 Constructs, checks, and returns an op of any type that involves an
3971 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
3972 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
3973 reference; calling this function does not transfer ownership of any
3974 reference to it.
3975
3976 =cut
3977 */
3978
3979 OP *
3980 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3981 {
3982     dVAR;
3983
3984     PERL_ARGS_ASSERT_NEWGVOP;
3985
3986 #ifdef USE_ITHREADS
3987     GvIN_PAD_on(gv);
3988     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3989 #else
3990     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3991 #endif
3992 }
3993
3994 /*
3995 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
3996
3997 Constructs, checks, and returns an op of any type that involves an
3998 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
3999 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
4000 must have been allocated using L</PerlMemShared_malloc>; the memory will
4001 be freed when the op is destroyed.
4002
4003 =cut
4004 */
4005
4006 OP *
4007 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4008 {
4009     dVAR;
4010     PVOP *pvop;
4011
4012     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4013         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4014
4015     NewOp(1101, pvop, 1, PVOP);
4016     pvop->op_type = (OPCODE)type;
4017     pvop->op_ppaddr = PL_ppaddr[type];
4018     pvop->op_pv = pv;
4019     pvop->op_next = (OP*)pvop;
4020     pvop->op_flags = (U8)flags;
4021     if (PL_opargs[type] & OA_RETSCALAR)
4022         scalar((OP*)pvop);
4023     if (PL_opargs[type] & OA_TARGET)
4024         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4025     return CHECKOP(type, pvop);
4026 }
4027
4028 #ifdef PERL_MAD
4029 OP*
4030 #else
4031 void
4032 #endif
4033 Perl_package(pTHX_ OP *o)
4034 {
4035     dVAR;
4036     SV *const sv = cSVOPo->op_sv;
4037 #ifdef PERL_MAD
4038     OP *pegop;
4039 #endif
4040
4041     PERL_ARGS_ASSERT_PACKAGE;
4042
4043     save_hptr(&PL_curstash);
4044     save_item(PL_curstname);
4045
4046     PL_curstash = gv_stashsv(sv, GV_ADD);
4047
4048     sv_setsv(PL_curstname, sv);
4049
4050     PL_hints |= HINT_BLOCK_SCOPE;
4051     PL_parser->copline = NOLINE;
4052     PL_parser->expect = XSTATE;
4053
4054 #ifndef PERL_MAD
4055     op_free(o);
4056 #else
4057     if (!PL_madskills) {
4058         op_free(o);
4059         return NULL;
4060     }
4061
4062     pegop = newOP(OP_NULL,0);
4063     op_getmad(o,pegop,'P');
4064     return pegop;
4065 #endif
4066 }
4067
4068 void
4069 Perl_package_version( pTHX_ OP *v )
4070 {
4071     dVAR;
4072     U32 savehints = PL_hints;
4073     PERL_ARGS_ASSERT_PACKAGE_VERSION;
4074     PL_hints &= ~HINT_STRICT_VARS;
4075     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4076     PL_hints = savehints;
4077     op_free(v);
4078 }
4079
4080 #ifdef PERL_MAD
4081 OP*
4082 #else
4083 void
4084 #endif
4085 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4086 {
4087     dVAR;
4088     OP *pack;
4089     OP *imop;
4090     OP *veop;
4091 #ifdef PERL_MAD
4092     OP *pegop = newOP(OP_NULL,0);
4093 #endif
4094
4095     PERL_ARGS_ASSERT_UTILIZE;
4096
4097     if (idop->op_type != OP_CONST)
4098         Perl_croak(aTHX_ "Module name must be constant");
4099
4100     if (PL_madskills)
4101         op_getmad(idop,pegop,'U');
4102
4103     veop = NULL;
4104
4105     if (version) {
4106         SV * const vesv = ((SVOP*)version)->op_sv;
4107
4108         if (PL_madskills)
4109             op_getmad(version,pegop,'V');
4110         if (!arg && !SvNIOKp(vesv)) {
4111             arg = version;
4112         }
4113         else {
4114             OP *pack;
4115             SV *meth;
4116
4117             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4118                 Perl_croak(aTHX_ "Version number must be a constant number");
4119
4120             /* Make copy of idop so we don't free it twice */
4121             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4122
4123             /* Fake up a method call to VERSION */
4124             meth = newSVpvs_share("VERSION");
4125             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4126                             append_elem(OP_LIST,
4127                                         prepend_elem(OP_LIST, pack, list(version)),
4128                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
4129         }
4130     }
4131
4132     /* Fake up an import/unimport */
4133     if (arg && arg->op_type == OP_STUB) {
4134         if (PL_madskills)
4135             op_getmad(arg,pegop,'S');
4136         imop = arg;             /* no import on explicit () */
4137     }
4138     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4139         imop = NULL;            /* use 5.0; */
4140         if (!aver)
4141             idop->op_private |= OPpCONST_NOVER;
4142     }
4143     else {
4144         SV *meth;
4145
4146         if (PL_madskills)
4147             op_getmad(arg,pegop,'A');
4148
4149         /* Make copy of idop so we don't free it twice */
4150         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4151
4152         /* Fake up a method call to import/unimport */
4153         meth = aver
4154             ? newSVpvs_share("import") : newSVpvs_share("unimport");
4155         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4156                        append_elem(OP_LIST,
4157                                    prepend_elem(OP_LIST, pack, list(arg)),
4158                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
4159     }
4160
4161     /* Fake up the BEGIN {}, which does its thing immediately. */
4162     newATTRSUB(floor,
4163         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4164         NULL,
4165         NULL,
4166         append_elem(OP_LINESEQ,
4167             append_elem(OP_LINESEQ,
4168                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4169                 newSTATEOP(0, NULL, veop)),
4170             newSTATEOP(0, NULL, imop) ));
4171
4172     /* The "did you use incorrect case?" warning used to be here.
4173      * The problem is that on case-insensitive filesystems one
4174      * might get false positives for "use" (and "require"):
4175      * "use Strict" or "require CARP" will work.  This causes
4176      * portability problems for the script: in case-strict
4177      * filesystems the script will stop working.
4178      *
4179      * The "incorrect case" warning checked whether "use Foo"
4180      * imported "Foo" to your namespace, but that is wrong, too:
4181      * there is no requirement nor promise in the language that
4182      * a Foo.pm should or would contain anything in package "Foo".
4183      *
4184      * There is very little Configure-wise that can be done, either:
4185      * the case-sensitivity of the build filesystem of Perl does not
4186      * help in guessing the case-sensitivity of the runtime environment.
4187      */
4188
4189     PL_hints |= HINT_BLOCK_SCOPE;
4190     PL_parser->copline = NOLINE;
4191     PL_parser->expect = XSTATE;
4192     PL_cop_seqmax++; /* Purely for B::*'s benefit */
4193
4194 #ifdef PERL_MAD
4195     if (!PL_madskills) {
4196         /* FIXME - don't allocate pegop if !PL_madskills */
4197         op_free(pegop);
4198         return NULL;
4199     }
4200     return pegop;
4201 #endif
4202 }
4203
4204 /*
4205 =head1 Embedding Functions
4206
4207 =for apidoc load_module
4208
4209 Loads the module whose name is pointed to by the string part of name.
4210 Note that the actual module name, not its filename, should be given.
4211 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4212 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4213 (or 0 for no flags). ver, if specified, provides version semantics
4214 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4215 arguments can be used to specify arguments to the module's import()
4216 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4217 terminated with a final NULL pointer.  Note that this list can only
4218 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4219 Otherwise at least a single NULL pointer to designate the default
4220 import list is required.
4221
4222 =cut */
4223
4224 void
4225 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4226 {
4227     va_list args;
4228
4229     PERL_ARGS_ASSERT_LOAD_MODULE;
4230
4231     va_start(args, ver);
4232     vload_module(flags, name, ver, &args);
4233     va_end(args);
4234 }
4235
4236 #ifdef PERL_IMPLICIT_CONTEXT
4237 void
4238 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4239 {
4240     dTHX;
4241     va_list args;
4242     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4243     va_start(args, ver);
4244     vload_module(flags, name, ver, &args);
4245     va_end(args);
4246 }
4247 #endif
4248
4249 void
4250 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4251 {
4252     dVAR;
4253     OP *veop, *imop;
4254     OP * const modname = newSVOP(OP_CONST, 0, name);
4255
4256     PERL_ARGS_ASSERT_VLOAD_MODULE;
4257
4258     modname->op_private |= OPpCONST_BARE;
4259     if (ver) {
4260         veop = newSVOP(OP_CONST, 0, ver);
4261     }
4262     else
4263         veop = NULL;
4264     if (flags & PERL_LOADMOD_NOIMPORT) {
4265         imop = sawparens(newNULLLIST());
4266     }
4267     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4268         imop = va_arg(*args, OP*);
4269     }
4270     else {
4271         SV *sv;
4272         imop = NULL;
4273         sv = va_arg(*args, SV*);
4274         while (sv) {
4275             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4276             sv = va_arg(*args, SV*);
4277         }
4278     }
4279
4280     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4281      * that it has a PL_parser to play with while doing that, and also
4282      * that it doesn't mess with any existing parser, by creating a tmp
4283      * new parser with lex_start(). This won't actually be used for much,
4284      * since pp_require() will create another parser for the real work. */
4285
4286     ENTER;
4287     SAVEVPTR(PL_curcop);
4288     lex_start(NULL, NULL, FALSE);
4289     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4290             veop, modname, imop);
4291     LEAVE;
4292 }
4293
4294 OP *
4295 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4296 {
4297     dVAR;
4298     OP *doop;
4299     GV *gv = NULL;
4300
4301     PERL_ARGS_ASSERT_DOFILE;
4302
4303     if (!force_builtin) {
4304         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4305         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4306             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4307             gv = gvp ? *gvp : NULL;
4308         }
4309     }
4310
4311     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4312         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4313                                append_elem(OP_LIST, term,
4314                                            scalar(newUNOP(OP_RV2CV, 0,
4315                                                           newGVOP(OP_GV, 0, gv))))));
4316     }
4317     else {
4318         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4319     }
4320     return doop;
4321 }
4322
4323 /*
4324 =head1 Optree construction
4325
4326 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4327
4328 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
4329 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4330 be set automatically, and, shifted up eight bits, the eight bits of
4331 C<op_private>, except that the bit with value 1 or 2 is automatically
4332 set as required.  I<listval> and I<subscript> supply the parameters of
4333 the slice; they are consumed by this function and become part of the
4334 constructed op tree.
4335
4336 =cut
4337 */
4338
4339 OP *
4340 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4341 {
4342     return newBINOP(OP_LSLICE, flags,
4343             list(force_list(subscript)),
4344             list(force_list(listval)) );
4345 }
4346
4347 STATIC I32
4348 S_is_list_assignment(pTHX_ register const OP *o)
4349 {
4350     unsigned type;
4351     U8 flags;
4352
4353     if (!o)
4354         return TRUE;
4355
4356     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4357         o = cUNOPo->op_first;
4358
4359     flags = o->op_flags;
4360     type = o->op_type;
4361     if (type == OP_COND_EXPR) {
4362         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4363         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4364
4365         if (t && f)
4366             return TRUE;
4367         if (t || f)
4368             yyerror("Assignment to both a list and a scalar");
4369         return FALSE;
4370     }
4371
4372     if (type == OP_LIST &&
4373         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4374         o->op_private & OPpLVAL_INTRO)
4375         return FALSE;
4376
4377     if (type == OP_LIST || flags & OPf_PARENS ||
4378         type == OP_RV2AV || type == OP_RV2HV ||
4379         type == OP_ASLICE || type == OP_HSLICE)
4380         return TRUE;
4381
4382     if (type == OP_PADAV || type == OP_PADHV)
4383         return TRUE;
4384
4385     if (type == OP_RV2SV)
4386         return FALSE;
4387
4388     return FALSE;
4389 }
4390
4391 /*
4392 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
4393
4394 Constructs, checks, and returns an assignment op.  I<left> and I<right>
4395 supply the parameters of the assignment; they are consumed by this
4396 function and become part of the constructed op tree.
4397
4398 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
4399 a suitable conditional optree is constructed.  If I<optype> is the opcode
4400 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
4401 performs the binary operation and assigns the result to the left argument.
4402 Either way, if I<optype> is non-zero then I<flags> has no effect.
4403
4404 If I<optype> is zero, then a plain scalar or list assignment is
4405 constructed.  Which type of assignment it is is automatically determined.
4406 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
4407 will be set automatically, and, shifted up eight bits, the eight bits
4408 of C<op_private>, except that the bit with value 1 or 2 is automatically
4409 set as required.
4410
4411 =cut
4412 */
4413
4414 OP *
4415 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4416 {
4417     dVAR;
4418     OP *o;
4419
4420     if (optype) {
4421         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4422             return newLOGOP(optype, 0,
4423                 mod(scalar(left), optype),
4424                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4425         }
4426         else {
4427             return newBINOP(optype, OPf_STACKED,
4428                 mod(scalar(left), optype), scalar(right));
4429         }
4430     }
4431
4432     if (is_list_assignment(left)) {
4433         static const char no_list_state[] = "Initialization of state variables"
4434             " in list context currently forbidden";
4435         OP *curop;
4436         bool maybe_common_vars = TRUE;
4437
4438         PL_modcount = 0;
4439         /* Grandfathering $[ assignment here.  Bletch.*/
4440         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4441         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4442         left = mod(left, OP_AASSIGN);
4443         if (PL_eval_start)
4444             PL_eval_start = 0;
4445         else if (left->op_type == OP_CONST) {
4446             deprecate("assignment to $[");
4447             /* FIXME for MAD */
4448             /* Result of assignment is always 1 (or we'd be dead already) */
4449             return newSVOP(OP_CONST, 0, newSViv(1));
4450         }
4451         curop = list(force_list(left));
4452         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4453         o->op_private = (U8)(0 | (flags >> 8));
4454
4455         if ((left->op_type == OP_LIST
4456              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4457         {
4458             OP* lop = ((LISTOP*)left)->op_first;
4459             maybe_common_vars = FALSE;
4460             while (lop) {
4461                 if (lop->op_type == OP_PADSV ||
4462                     lop->op_type == OP_PADAV ||
4463                     lop->op_type == OP_PADHV ||
4464                     lop->op_type == OP_PADANY) {
4465                     if (!(lop->op_private & OPpLVAL_INTRO))
4466                         maybe_common_vars = TRUE;
4467
4468                     if (lop->op_private & OPpPAD_STATE) {
4469                         if (left->op_private & OPpLVAL_INTRO) {
4470                             /* Each variable in state($a, $b, $c) = ... */
4471                         }
4472                         else {
4473                             /* Each state variable in
4474                                (state $a, my $b, our $c, $d, undef) = ... */
4475                         }
4476                         yyerror(no_list_state);
4477                     } else {
4478                         /* Each my variable in
4479                            (state $a, my $b, our $c, $d, undef) = ... */
4480                     }
4481                 } else if (lop->op_type == OP_UNDEF ||
4482                            lop->op_type == OP_PUSHMARK) {
4483                     /* undef may be interesting in
4484                        (state $a, undef, state $c) */
4485                 } else {
4486                     /* Other ops in the list. */
4487                     maybe_common_vars = TRUE;
4488                 }
4489                 lop = lop->op_sibling;
4490             }
4491         }
4492         else if ((left->op_private & OPpLVAL_INTRO)
4493                 && (   left->op_type == OP_PADSV
4494                     || left->op_type == OP_PADAV
4495                     || left->op_type == OP_PADHV
4496                     || left->op_type == OP_PADANY))
4497         {
4498             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
4499             if (left->op_private & OPpPAD_STATE) {
4500                 /* All single variable list context state assignments, hence
4501                    state ($a) = ...
4502                    (state $a) = ...
4503                    state @a = ...
4504                    state (@a) = ...
4505                    (state @a) = ...
4506                    state %a = ...
4507                    state (%a) = ...
4508                    (state %a) = ...
4509                 */
4510                 yyerror(no_list_state);
4511             }
4512         }
4513
4514         /* PL_generation sorcery:
4515          * an assignment like ($a,$b) = ($c,$d) is easier than
4516          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4517          * To detect whether there are common vars, the global var
4518          * PL_generation is incremented for each assign op we compile.
4519          * Then, while compiling the assign op, we run through all the
4520          * variables on both sides of the assignment, setting a spare slot
4521          * in each of them to PL_generation. If any of them already have
4522          * that value, we know we've got commonality.  We could use a
4523          * single bit marker, but then we'd have to make 2 passes, first
4524          * to clear the flag, then to test and set it.  To find somewhere
4525          * to store these values, evil chicanery is done with SvUVX().
4526          */
4527
4528         if (maybe_common_vars) {
4529             OP *lastop = o;
4530             PL_generation++;
4531             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4532                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4533                     if (curop->op_type == OP_GV) {
4534                         GV *gv = cGVOPx_gv(curop);
4535                         if (gv == PL_defgv
4536                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4537                             break;
4538                         GvASSIGN_GENERATION_set(gv, PL_generation);
4539                     }
4540                     else if (curop->op_type == OP_PADSV ||
4541                              curop->op_type == OP_PADAV ||
4542                              curop->op_type == OP_PADHV ||
4543                              curop->op_type == OP_PADANY)
4544                     {
4545                         if (PAD_COMPNAME_GEN(curop->op_targ)
4546                                                     == (STRLEN)PL_generation)
4547                             break;
4548                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4549
4550                     }
4551                     else if (curop->op_type == OP_RV2CV)
4552                         break;
4553                     else if (curop->op_type == OP_RV2SV ||
4554                              curop->op_type == OP_RV2AV ||
4555                              curop->op_type == OP_RV2HV ||
4556                              curop->op_type == OP_RV2GV) {
4557                         if (lastop->op_type != OP_GV)   /* funny deref? */
4558                             break;
4559                     }
4560                     else if (curop->op_type == OP_PUSHRE) {
4561 #ifdef USE_ITHREADS
4562                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4563                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4564                             if (gv == PL_defgv
4565                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4566                                 break;
4567                             GvASSIGN_GENERATION_set(gv, PL_generation);
4568                         }
4569 #else
4570                         GV *const gv
4571                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4572                         if (gv) {
4573                             if (gv == PL_defgv
4574                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4575                                 break;
4576                             GvASSIGN_GENERATION_set(gv, PL_generation);
4577                         }
4578 #endif
4579                     }
4580                     else
4581                         break;
4582                 }
4583                 lastop = curop;
4584             }
4585             if (curop != o)
4586                 o->op_private |= OPpASSIGN_COMMON;
4587         }
4588
4589         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4590             OP* tmpop = ((LISTOP*)right)->op_first;
4591             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4592                 PMOP * const pm = (PMOP*)tmpop;
4593                 if (left->op_type == OP_RV2AV &&
4594                     !(left->op_private & OPpLVAL_INTRO) &&
4595                     !(o->op_private & OPpASSIGN_COMMON) )
4596                 {
4597                     tmpop = ((UNOP*)left)->op_first;
4598                     if (tmpop->op_type == OP_GV
4599 #ifdef USE_ITHREADS
4600                         && !pm->op_pmreplrootu.op_pmtargetoff
4601 #else
4602                         && !pm->op_pmreplrootu.op_pmtargetgv
4603 #endif
4604                         ) {
4605 #ifdef USE_ITHREADS
4606                         pm->op_pmreplrootu.op_pmtargetoff
4607                             = cPADOPx(tmpop)->op_padix;
4608                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4609 #else
4610                         pm->op_pmreplrootu.op_pmtargetgv
4611                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4612                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4613 #endif
4614                         pm->op_pmflags |= PMf_ONCE;
4615                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4616                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4617                         tmpop->op_sibling = NULL;       /* don't free split */
4618                         right->op_next = tmpop->op_next;  /* fix starting loc */
4619                         op_free(o);                     /* blow off assign */
4620                         right->op_flags &= ~OPf_WANT;
4621                                 /* "I don't know and I don't care." */
4622                         return right;
4623                     }
4624                 }
4625                 else {
4626                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4627                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4628                     {
4629                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4630                         if (SvIOK(sv) && SvIVX(sv) == 0)
4631                             sv_setiv(sv, PL_modcount+1);
4632                     }
4633                 }
4634             }
4635         }
4636         return o;
4637     }
4638     if (!right)
4639         right = newOP(OP_UNDEF, 0);
4640     if (right->op_type == OP_READLINE) {
4641         right->op_flags |= OPf_STACKED;
4642         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4643     }
4644     else {
4645         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4646         o = newBINOP(OP_SASSIGN, flags,
4647             scalar(right), mod(scalar(left), OP_SASSIGN) );
4648         if (PL_eval_start)
4649             PL_eval_start = 0;
4650         else {
4651             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4652                 deprecate("assignment to $[");
4653                 op_free(o);
4654                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4655                 o->op_private |= OPpCONST_ARYBASE;
4656             }
4657         }
4658     }
4659     return o;
4660 }
4661
4662 /*
4663 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
4664
4665 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
4666 but will be a C<dbstate> op if debugging is enabled for currently-compiled
4667 code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
4668 If I<label> is non-null, it supplies the name of a label to attach to
4669 the state op; this function takes ownership of the memory pointed at by
4670 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
4671 for the state op.
4672
4673 If I<o> is null, the state op is returned.  Otherwise the state op is
4674 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
4675 is consumed by this function and becomes part of the returned op tree.
4676
4677 =cut
4678 */
4679
4680 OP *
4681 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4682 {
4683     dVAR;
4684     const U32 seq = intro_my();
4685     register COP *cop;
4686
4687     NewOp(1101, cop, 1, COP);
4688     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4689         cop->op_type = OP_DBSTATE;
4690         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4691     }
4692     else {
4693         cop->op_type = OP_NEXTSTATE;
4694         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4695     }
4696     cop->op_flags = (U8)flags;
4697     CopHINTS_set(cop, PL_hints);
4698 #ifdef NATIVE_HINTS
4699     cop->op_private |= NATIVE_HINTS;
4700 #endif
4701     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4702     cop->op_next = (OP*)cop;
4703
4704     cop->cop_seq = seq;
4705     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4706        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4707     */
4708     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4709     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4710     if (cop->cop_hints_hash) {
4711         HINTS_REFCNT_LOCK;
4712         cop->cop_hints_hash->refcounted_he_refcnt++;
4713         HINTS_REFCNT_UNLOCK;
4714     }
4715     if (label) {
4716         Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
4717                                                      
4718         PL_hints |= HINT_BLOCK_SCOPE;
4719         /* It seems that we need to defer freeing this pointer, as other parts
4720            of the grammar end up wanting to copy it after this op has been
4721            created. */
4722         SAVEFREEPV(label);
4723     }
4724
4725     if (PL_parser && PL_parser->copline == NOLINE)
4726         CopLINE_set(cop, CopLINE(PL_curcop));
4727     else {
4728         CopLINE_set(cop, PL_parser->copline);
4729         if (PL_parser)
4730             PL_parser->copline = NOLINE;
4731     }
4732 #ifdef USE_ITHREADS
4733     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4734 #else
4735     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4736 #endif
4737     CopSTASH_set(cop, PL_curstash);
4738
4739     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4740         /* this line can have a breakpoint - store the cop in IV */
4741         AV *av = CopFILEAVx(PL_curcop);
4742         if (av) {
4743             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4744             if (svp && *svp != &PL_sv_undef ) {
4745                 (void)SvIOK_on(*svp);
4746                 SvIV_set(*svp, PTR2IV(cop));
4747             }
4748         }
4749     }
4750
4751     if (flags & OPf_SPECIAL)
4752         op_null((OP*)cop);
4753     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4754 }
4755
4756 /*
4757 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
4758
4759 Constructs, checks, and returns a logical (flow control) op.  I<type>
4760 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4761 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4762 the eight bits of C<op_private>, except that the bit with value 1 is
4763 automatically set.  I<first> supplies the expression controlling the
4764 flow, and I<other> supplies the side (alternate) chain of ops; they are
4765 consumed by this function and become part of the constructed op tree.
4766
4767 =cut
4768 */
4769
4770 OP *
4771 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4772 {
4773     dVAR;
4774
4775     PERL_ARGS_ASSERT_NEWLOGOP;
4776
4777     return new_logop(type, flags, &first, &other);
4778 }
4779
4780 STATIC OP *
4781 S_search_const(pTHX_ OP *o)
4782 {
4783     PERL_ARGS_ASSERT_SEARCH_CONST;
4784
4785     switch (o->op_type) {
4786         case OP_CONST:
4787             return o;
4788         case OP_NULL:
4789             if (o->op_flags & OPf_KIDS)
4790                 return search_const(cUNOPo->op_first);
4791             break;
4792         case OP_LEAVE:
4793         case OP_SCOPE:
4794         case OP_LINESEQ:
4795         {
4796             OP *kid;
4797             if (!(o->op_flags & OPf_KIDS))
4798                 return NULL;
4799             kid = cLISTOPo->op_first;
4800             do {
4801                 switch (kid->op_type) {
4802                     case OP_ENTER:
4803                     case OP_NULL:
4804                     case OP_NEXTSTATE:
4805                         kid = kid->op_sibling;
4806                         break;
4807                     default:
4808                         if (kid != cLISTOPo->op_last)
4809                             return NULL;
4810                         goto last;
4811                 }
4812             } while (kid);
4813             if (!kid)
4814                 kid = cLISTOPo->op_last;
4815 last:
4816             return search_const(kid);
4817         }
4818     }
4819
4820     return NULL;
4821 }
4822
4823 STATIC OP *
4824 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4825 {
4826     dVAR;
4827     LOGOP *logop;
4828     OP *o;
4829     OP *first;
4830     OP *other;
4831     OP *cstop = NULL;
4832     int prepend_not = 0;
4833
4834     PERL_ARGS_ASSERT_NEW_LOGOP;
4835
4836     first = *firstp;
4837     other = *otherp;
4838
4839     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4840         return newBINOP(type, flags, scalar(first), scalar(other));
4841
4842     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
4843
4844     scalarboolean(first);
4845     /* optimize AND and OR ops that have NOTs as children */
4846     if (first->op_type == OP_NOT
4847         && (first->op_flags & OPf_KIDS)
4848         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4849             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
4850         && !PL_madskills) {
4851         if (type == OP_AND || type == OP_OR) {
4852             if (type == OP_AND)
4853                 type = OP_OR;
4854             else
4855                 type = OP_AND;
4856             op_null(first);
4857             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4858                 op_null(other);
4859                 prepend_not = 1; /* prepend a NOT op later */
4860             }
4861         }
4862     }
4863     /* search for a constant op that could let us fold the test */
4864     if ((cstop = search_const(first))) {
4865         if (cstop->op_private & OPpCONST_STRICT)
4866             no_bareword_allowed(cstop);
4867         else if ((cstop->op_private & OPpCONST_BARE))
4868                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4869         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
4870             (