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