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