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