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