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