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