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