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