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