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