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