This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
de36cede7fb7757e0fdde5c1e7b7a95dcbd131de
[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             o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3471             o->op_private |= OPpCONST_ARYBASE;
3472         }
3473     }
3474     return o;
3475 }
3476
3477 OP *
3478 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3479 {
3480     dVAR;
3481     const U32 seq = intro_my();
3482     register COP *cop;
3483
3484     NewOp(1101, cop, 1, COP);
3485     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3486         cop->op_type = OP_DBSTATE;
3487         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3488     }
3489     else {
3490         cop->op_type = OP_NEXTSTATE;
3491         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3492     }
3493     cop->op_flags = (U8)flags;
3494     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3495 #ifdef NATIVE_HINTS
3496     cop->op_private |= NATIVE_HINTS;
3497 #endif
3498     PL_compiling.op_private = cop->op_private;
3499     cop->op_next = (OP*)cop;
3500
3501     if (label) {
3502         cop->cop_label = label;
3503         PL_hints |= HINT_BLOCK_SCOPE;
3504     }
3505     cop->cop_seq = seq;
3506     cop->cop_arybase = PL_curcop->cop_arybase;
3507     if (specialWARN(PL_curcop->cop_warnings))
3508         cop->cop_warnings = PL_curcop->cop_warnings ;
3509     else
3510         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3511     if (specialCopIO(PL_curcop->cop_io))
3512         cop->cop_io = PL_curcop->cop_io;
3513     else
3514         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3515
3516
3517     if (PL_copline == NOLINE)
3518         CopLINE_set(cop, CopLINE(PL_curcop));
3519     else {
3520         CopLINE_set(cop, PL_copline);
3521         PL_copline = NOLINE;
3522     }
3523 #ifdef USE_ITHREADS
3524     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3525 #else
3526     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3527 #endif
3528     CopSTASH_set(cop, PL_curstash);
3529
3530     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3531         SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3532         if (svp && *svp != &PL_sv_undef ) {
3533             (void)SvIOK_on(*svp);
3534             SvIV_set(*svp, PTR2IV(cop));
3535         }
3536     }
3537
3538     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3539 }
3540
3541
3542 OP *
3543 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3544 {
3545     dVAR;
3546     return new_logop(type, flags, &first, &other);
3547 }
3548
3549 STATIC OP *
3550 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3551 {
3552     dVAR;
3553     LOGOP *logop;
3554     OP *o;
3555     OP *first = *firstp;
3556     OP * const other = *otherp;
3557
3558     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3559         return newBINOP(type, flags, scalar(first), scalar(other));
3560
3561     scalarboolean(first);
3562     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3563     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3564         if (type == OP_AND || type == OP_OR) {
3565             if (type == OP_AND)
3566                 type = OP_OR;
3567             else
3568                 type = OP_AND;
3569             o = first;
3570             first = *firstp = cUNOPo->op_first;
3571             if (o->op_next)
3572                 first->op_next = o->op_next;
3573             cUNOPo->op_first = NULL;
3574             op_free(o);
3575         }
3576     }
3577     if (first->op_type == OP_CONST) {
3578         if (first->op_private & OPpCONST_STRICT)
3579             no_bareword_allowed(first);
3580         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3581                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3582         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3583             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3584             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3585             op_free(first);
3586             *firstp = NULL;
3587             if (other->op_type == OP_CONST)
3588                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3589             return other;
3590         }
3591         else {
3592             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3593             const OP *o2 = other;
3594             if ( ! (o2->op_type == OP_LIST
3595                     && (( o2 = cUNOPx(o2)->op_first))
3596                     && o2->op_type == OP_PUSHMARK
3597                     && (( o2 = o2->op_sibling)) )
3598             )
3599                 o2 = other;
3600             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3601                         || o2->op_type == OP_PADHV)
3602                 && o2->op_private & OPpLVAL_INTRO
3603                 && ckWARN(WARN_DEPRECATED))
3604             {
3605                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3606                             "Deprecated use of my() in false conditional");
3607             }
3608
3609             op_free(other);
3610             *otherp = NULL;
3611             if (first->op_type == OP_CONST)
3612                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3613             return first;
3614         }
3615     }
3616     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3617         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3618     {
3619         const OP * const k1 = ((UNOP*)first)->op_first;
3620         const OP * const k2 = k1->op_sibling;
3621         OPCODE warnop = 0;
3622         switch (first->op_type)
3623         {
3624         case OP_NULL:
3625             if (k2 && k2->op_type == OP_READLINE
3626                   && (k2->op_flags & OPf_STACKED)
3627                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3628             {
3629                 warnop = k2->op_type;
3630             }
3631             break;
3632
3633         case OP_SASSIGN:
3634             if (k1->op_type == OP_READDIR
3635                   || k1->op_type == OP_GLOB
3636                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3637                   || k1->op_type == OP_EACH)
3638             {
3639                 warnop = ((k1->op_type == OP_NULL)
3640                           ? (OPCODE)k1->op_targ : k1->op_type);
3641             }
3642             break;
3643         }
3644         if (warnop) {
3645             const line_t oldline = CopLINE(PL_curcop);
3646             CopLINE_set(PL_curcop, PL_copline);
3647             Perl_warner(aTHX_ packWARN(WARN_MISC),
3648                  "Value of %s%s can be \"0\"; test with defined()",
3649                  PL_op_desc[warnop],
3650                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3651                   ? " construct" : "() operator"));
3652             CopLINE_set(PL_curcop, oldline);
3653         }
3654     }
3655
3656     if (!other)
3657         return first;
3658
3659     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3660         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3661
3662     NewOp(1101, logop, 1, LOGOP);
3663
3664     logop->op_type = (OPCODE)type;
3665     logop->op_ppaddr = PL_ppaddr[type];
3666     logop->op_first = first;
3667     logop->op_flags = (U8)(flags | OPf_KIDS);
3668     logop->op_other = LINKLIST(other);
3669     logop->op_private = (U8)(1 | (flags >> 8));
3670
3671     /* establish postfix order */
3672     logop->op_next = LINKLIST(first);
3673     first->op_next = (OP*)logop;
3674     first->op_sibling = other;
3675
3676     CHECKOP(type,logop);
3677
3678     o = newUNOP(OP_NULL, 0, (OP*)logop);
3679     other->op_next = o;
3680
3681     return o;
3682 }
3683
3684 OP *
3685 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3686 {
3687     dVAR;
3688     LOGOP *logop;
3689     OP *start;
3690     OP *o;
3691
3692     if (!falseop)
3693         return newLOGOP(OP_AND, 0, first, trueop);
3694     if (!trueop)
3695         return newLOGOP(OP_OR, 0, first, falseop);
3696
3697     scalarboolean(first);
3698     if (first->op_type == OP_CONST) {
3699         if (first->op_private & OPpCONST_BARE &&
3700             first->op_private & OPpCONST_STRICT) {
3701             no_bareword_allowed(first);
3702         }
3703         if (SvTRUE(((SVOP*)first)->op_sv)) {
3704             op_free(first);
3705             op_free(falseop);
3706             return trueop;
3707         }
3708         else {
3709             op_free(first);
3710             op_free(trueop);
3711             return falseop;
3712         }
3713     }
3714     NewOp(1101, logop, 1, LOGOP);
3715     logop->op_type = OP_COND_EXPR;
3716     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3717     logop->op_first = first;
3718     logop->op_flags = (U8)(flags | OPf_KIDS);
3719     logop->op_private = (U8)(1 | (flags >> 8));
3720     logop->op_other = LINKLIST(trueop);
3721     logop->op_next = LINKLIST(falseop);
3722
3723     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3724             logop);
3725
3726     /* establish postfix order */
3727     start = LINKLIST(first);
3728     first->op_next = (OP*)logop;
3729
3730     first->op_sibling = trueop;
3731     trueop->op_sibling = falseop;
3732     o = newUNOP(OP_NULL, 0, (OP*)logop);
3733
3734     trueop->op_next = falseop->op_next = o;
3735
3736     o->op_next = start;
3737     return o;
3738 }
3739
3740 OP *
3741 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3742 {
3743     dVAR;
3744     LOGOP *range;
3745     OP *flip;
3746     OP *flop;
3747     OP *leftstart;
3748     OP *o;
3749
3750     NewOp(1101, range, 1, LOGOP);
3751
3752     range->op_type = OP_RANGE;
3753     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3754     range->op_first = left;
3755     range->op_flags = OPf_KIDS;
3756     leftstart = LINKLIST(left);
3757     range->op_other = LINKLIST(right);
3758     range->op_private = (U8)(1 | (flags >> 8));
3759
3760     left->op_sibling = right;
3761
3762     range->op_next = (OP*)range;
3763     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3764     flop = newUNOP(OP_FLOP, 0, flip);
3765     o = newUNOP(OP_NULL, 0, flop);
3766     linklist(flop);
3767     range->op_next = leftstart;
3768
3769     left->op_next = flip;
3770     right->op_next = flop;
3771
3772     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3773     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3774     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3775     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3776
3777     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3778     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3779
3780     flip->op_next = o;
3781     if (!flip->op_private || !flop->op_private)
3782         linklist(o);            /* blow off optimizer unless constant */
3783
3784     return o;
3785 }
3786
3787 OP *
3788 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3789 {
3790     dVAR;
3791     OP* listop;
3792     OP* o;
3793     const bool once = block && block->op_flags & OPf_SPECIAL &&
3794       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3795
3796     PERL_UNUSED_ARG(debuggable);
3797
3798     if (expr) {
3799         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3800             return block;       /* do {} while 0 does once */
3801         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3802             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3803             expr = newUNOP(OP_DEFINED, 0,
3804                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3805         } else if (expr->op_flags & OPf_KIDS) {
3806             const OP * const k1 = ((UNOP*)expr)->op_first;
3807             const OP * const k2 = k1 ? k1->op_sibling : NULL;
3808             switch (expr->op_type) {
3809               case OP_NULL:
3810                 if (k2 && k2->op_type == OP_READLINE
3811                       && (k2->op_flags & OPf_STACKED)
3812                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3813                     expr = newUNOP(OP_DEFINED, 0, expr);
3814                 break;
3815
3816               case OP_SASSIGN:
3817                 if (k1->op_type == OP_READDIR
3818                       || k1->op_type == OP_GLOB
3819                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3820                       || k1->op_type == OP_EACH)
3821                     expr = newUNOP(OP_DEFINED, 0, expr);
3822                 break;
3823             }
3824         }
3825     }
3826
3827     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3828      * op, in listop. This is wrong. [perl #27024] */
3829     if (!block)
3830         block = newOP(OP_NULL, 0);
3831     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3832     o = new_logop(OP_AND, 0, &expr, &listop);
3833
3834     if (listop)
3835         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3836
3837     if (once && o != listop)
3838         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3839
3840     if (o == listop)
3841         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3842
3843     o->op_flags |= flags;
3844     o = scope(o);
3845     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3846     return o;
3847 }
3848
3849 OP *
3850 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3851 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3852 {
3853     dVAR;
3854     OP *redo;
3855     OP *next = NULL;
3856     OP *listop;
3857     OP *o;
3858     U8 loopflags = 0;
3859
3860     PERL_UNUSED_ARG(debuggable);
3861
3862     if (expr) {
3863         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3864                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3865             expr = newUNOP(OP_DEFINED, 0,
3866                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3867         } else if (expr->op_flags & OPf_KIDS) {
3868             const OP * const k1 = ((UNOP*)expr)->op_first;
3869             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3870             switch (expr->op_type) {
3871               case OP_NULL:
3872                 if (k2 && k2->op_type == OP_READLINE
3873                       && (k2->op_flags & OPf_STACKED)
3874                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3875                     expr = newUNOP(OP_DEFINED, 0, expr);
3876                 break;
3877
3878               case OP_SASSIGN:
3879                 if (k1->op_type == OP_READDIR
3880                       || k1->op_type == OP_GLOB
3881                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3882                       || k1->op_type == OP_EACH)
3883                     expr = newUNOP(OP_DEFINED, 0, expr);
3884                 break;
3885             }
3886         }
3887     }
3888
3889     if (!block)
3890         block = newOP(OP_NULL, 0);
3891     else if (cont || has_my) {
3892         block = scope(block);
3893     }
3894
3895     if (cont) {
3896         next = LINKLIST(cont);
3897     }
3898     if (expr) {
3899         OP * const unstack = newOP(OP_UNSTACK, 0);
3900         if (!next)
3901             next = unstack;
3902         cont = append_elem(OP_LINESEQ, cont, unstack);
3903     }
3904
3905     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3906     redo = LINKLIST(listop);
3907
3908     if (expr) {
3909         PL_copline = (line_t)whileline;
3910         scalar(listop);
3911         o = new_logop(OP_AND, 0, &expr, &listop);
3912         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3913             op_free(expr);              /* oops, it's a while (0) */
3914             op_free((OP*)loop);
3915             return NULL;                /* listop already freed by new_logop */
3916         }
3917         if (listop)
3918             ((LISTOP*)listop)->op_last->op_next =
3919                 (o == listop ? redo : LINKLIST(o));
3920     }
3921     else
3922         o = listop;
3923
3924     if (!loop) {
3925         NewOp(1101,loop,1,LOOP);
3926         loop->op_type = OP_ENTERLOOP;
3927         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3928         loop->op_private = 0;
3929         loop->op_next = (OP*)loop;
3930     }
3931
3932     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3933
3934     loop->op_redoop = redo;
3935     loop->op_lastop = o;
3936     o->op_private |= loopflags;
3937
3938     if (next)
3939         loop->op_nextop = next;
3940     else
3941         loop->op_nextop = o;
3942
3943     o->op_flags |= flags;
3944     o->op_private |= (flags >> 8);
3945     return o;
3946 }
3947
3948 OP *
3949 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3950 {
3951     dVAR;
3952     LOOP *loop;
3953     OP *wop;
3954     PADOFFSET padoff = 0;
3955     I32 iterflags = 0;
3956     I32 iterpflags = 0;
3957
3958     if (sv) {
3959         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3960             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3961             sv->op_type = OP_RV2GV;
3962             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3963             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3964                 iterpflags |= OPpITER_DEF;
3965         }
3966         else if (sv->op_type == OP_PADSV) { /* private variable */
3967             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3968             padoff = sv->op_targ;
3969             sv->op_targ = 0;
3970             op_free(sv);
3971             sv = NULL;
3972         }
3973         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3974             padoff = sv->op_targ;
3975             sv->op_targ = 0;
3976             iterflags |= OPf_SPECIAL;
3977             op_free(sv);
3978             sv = NULL;
3979         }
3980         else
3981             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3982         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3983             iterpflags |= OPpITER_DEF;
3984     }
3985     else {
3986         const I32 offset = pad_findmy("$_");
3987         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3988             sv = newGVOP(OP_GV, 0, PL_defgv);
3989         }
3990         else {
3991             padoff = offset;
3992         }
3993         iterpflags |= OPpITER_DEF;
3994     }
3995     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3996         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3997         iterflags |= OPf_STACKED;
3998     }
3999     else if (expr->op_type == OP_NULL &&
4000              (expr->op_flags & OPf_KIDS) &&
4001              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4002     {
4003         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4004          * set the STACKED flag to indicate that these values are to be
4005          * treated as min/max values by 'pp_iterinit'.
4006          */
4007         UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4008         LOGOP* const range = (LOGOP*) flip->op_first;
4009         OP* const left  = range->op_first;
4010         OP* const right = left->op_sibling;
4011         LISTOP* listop;
4012
4013         range->op_flags &= ~OPf_KIDS;
4014         range->op_first = NULL;
4015
4016         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4017         listop->op_first->op_next = range->op_next;
4018         left->op_next = range->op_other;
4019         right->op_next = (OP*)listop;
4020         listop->op_next = listop->op_first;
4021
4022         op_free(expr);
4023         expr = (OP*)(listop);
4024         op_null(expr);
4025         iterflags |= OPf_STACKED;
4026     }
4027     else {
4028         expr = mod(force_list(expr), OP_GREPSTART);
4029     }
4030
4031     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4032                                append_elem(OP_LIST, expr, scalar(sv))));
4033     assert(!loop->op_next);
4034     /* for my  $x () sets OPpLVAL_INTRO;
4035      * for our $x () sets OPpOUR_INTRO */
4036     loop->op_private = (U8)iterpflags;
4037 #ifdef PL_OP_SLAB_ALLOC
4038     {
4039         LOOP *tmp;
4040         NewOp(1234,tmp,1,LOOP);
4041         Copy(loop,tmp,1,LISTOP);
4042         FreeOp(loop);
4043         loop = tmp;
4044     }
4045 #else
4046     Renew(loop, 1, LOOP);
4047 #endif
4048     loop->op_targ = padoff;
4049     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4050     PL_copline = forline;
4051     return newSTATEOP(0, label, wop);
4052 }
4053
4054 OP*
4055 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4056 {
4057     dVAR;
4058     OP *o;
4059
4060     if (type != OP_GOTO || label->op_type == OP_CONST) {
4061         /* "last()" means "last" */
4062         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4063             o = newOP(type, OPf_SPECIAL);
4064         else {
4065             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4066                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4067                                         : ""));
4068         }
4069         op_free(label);
4070     }
4071     else {
4072         /* Check whether it's going to be a goto &function */
4073         if (label->op_type == OP_ENTERSUB
4074                 && !(label->op_flags & OPf_STACKED))
4075             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4076         o = newUNOP(type, OPf_STACKED, label);
4077     }
4078     PL_hints |= HINT_BLOCK_SCOPE;
4079     return o;
4080 }
4081
4082 /* if the condition is a literal array or hash
4083    (or @{ ... } etc), make a reference to it.
4084  */
4085 STATIC OP *
4086 S_ref_array_or_hash(pTHX_ OP *cond)
4087 {
4088     if (cond
4089     && (cond->op_type == OP_RV2AV
4090     ||  cond->op_type == OP_PADAV
4091     ||  cond->op_type == OP_RV2HV
4092     ||  cond->op_type == OP_PADHV))
4093
4094         return newUNOP(OP_REFGEN,
4095             0, mod(cond, OP_REFGEN));
4096
4097     else
4098         return cond;
4099 }
4100
4101 /* These construct the optree fragments representing given()
4102    and when() blocks.
4103
4104    entergiven and enterwhen are LOGOPs; the op_other pointer
4105    points up to the associated leave op. We need this so we
4106    can put it in the context and make break/continue work.
4107    (Also, of course, pp_enterwhen will jump straight to
4108    op_other if the match fails.)
4109  */
4110
4111 STATIC
4112 OP *
4113 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4114                    I32 enter_opcode, I32 leave_opcode,
4115                    PADOFFSET entertarg)
4116 {
4117     dVAR;
4118     LOGOP *enterop;
4119     OP *o;
4120
4121     NewOp(1101, enterop, 1, LOGOP);
4122     enterop->op_type = enter_opcode;
4123     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4124     enterop->op_flags =  (U8) OPf_KIDS;
4125     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4126     enterop->op_private = 0;
4127
4128     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4129
4130     if (cond) {
4131         enterop->op_first = scalar(cond);
4132         cond->op_sibling = block;
4133
4134         o->op_next = LINKLIST(cond);
4135         cond->op_next = (OP *) enterop;
4136     }
4137     else {
4138         /* This is a default {} block */
4139         enterop->op_first = block;
4140         enterop->op_flags |= OPf_SPECIAL;
4141
4142         o->op_next = (OP *) enterop;
4143     }
4144
4145     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4146                                        entergiven and enterwhen both
4147                                        use ck_null() */
4148
4149     enterop->op_next = LINKLIST(block);
4150     block->op_next = enterop->op_other = o;
4151
4152     return o;
4153 }
4154
4155 /* Does this look like a boolean operation? For these purposes
4156    a boolean operation is:
4157      - a subroutine call [*]
4158      - a logical connective
4159      - a comparison operator
4160      - a filetest operator, with the exception of -s -M -A -C
4161      - defined(), exists() or eof()
4162      - /$re/ or $foo =~ /$re/
4163    
4164    [*] possibly surprising
4165  */
4166 STATIC
4167 bool
4168 S_looks_like_bool(pTHX_ OP *o)
4169 {
4170     dVAR;
4171     switch(o->op_type) {
4172         case OP_OR:
4173             return looks_like_bool(cLOGOPo->op_first);
4174
4175         case OP_AND:
4176             return (
4177                 looks_like_bool(cLOGOPo->op_first)
4178              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4179
4180         case OP_ENTERSUB:
4181
4182         case OP_NOT:    case OP_XOR:
4183         /* Note that OP_DOR is not here */
4184
4185         case OP_EQ:     case OP_NE:     case OP_LT:
4186         case OP_GT:     case OP_LE:     case OP_GE:
4187
4188         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4189         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4190
4191         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4192         case OP_SGT:    case OP_SLE:    case OP_SGE:
4193         
4194         case OP_SMARTMATCH:
4195         
4196         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4197         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4198         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4199         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4200         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4201         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4202         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4203         case OP_FTTEXT:   case OP_FTBINARY:
4204         
4205         case OP_DEFINED: case OP_EXISTS:
4206         case OP_MATCH:   case OP_EOF:
4207
4208             return TRUE;
4209         
4210         case OP_CONST:
4211             /* Detect comparisons that have been optimized away */
4212             if (cSVOPo->op_sv == &PL_sv_yes
4213             ||  cSVOPo->op_sv == &PL_sv_no)
4214             
4215                 return TRUE;
4216                 
4217         /* FALL THROUGH */
4218         default:
4219             return FALSE;
4220     }
4221 }
4222
4223 OP *
4224 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4225 {
4226     dVAR;
4227     assert( cond );
4228     return newGIVWHENOP(
4229         ref_array_or_hash(cond),
4230         block,
4231         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4232         defsv_off);
4233 }
4234
4235 /* If cond is null, this is a default {} block */
4236 OP *
4237 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4238 {
4239     bool cond_llb = (!cond || looks_like_bool(cond));
4240     OP *cond_op;
4241
4242     if (cond_llb)
4243         cond_op = cond;
4244     else {
4245         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4246                 newDEFSVOP(),
4247                 scalar(ref_array_or_hash(cond)));
4248     }
4249     
4250     return newGIVWHENOP(
4251         cond_op,
4252         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4253         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4254 }
4255
4256 /*
4257 =for apidoc cv_undef
4258
4259 Clear out all the active components of a CV. This can happen either
4260 by an explicit C<undef &foo>, or by the reference count going to zero.
4261 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4262 children can still follow the full lexical scope chain.
4263
4264 =cut
4265 */
4266
4267 void
4268 Perl_cv_undef(pTHX_ CV *cv)
4269 {
4270     dVAR;
4271 #ifdef USE_ITHREADS
4272     if (CvFILE(cv) && !CvISXSUB(cv)) {
4273         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4274         Safefree(CvFILE(cv));
4275     }
4276     CvFILE(cv) = 0;
4277 #endif
4278
4279     if (!CvISXSUB(cv) && CvROOT(cv)) {
4280         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4281             Perl_croak(aTHX_ "Can't undef active subroutine");
4282         ENTER;
4283
4284         PAD_SAVE_SETNULLPAD();
4285
4286         op_free(CvROOT(cv));
4287         CvROOT(cv) = NULL;
4288         CvSTART(cv) = NULL;
4289         LEAVE;
4290     }
4291     SvPOK_off((SV*)cv);         /* forget prototype */
4292     CvGV(cv) = NULL;
4293
4294     pad_undef(cv);
4295
4296     /* remove CvOUTSIDE unless this is an undef rather than a free */
4297     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4298         if (!CvWEAKOUTSIDE(cv))
4299             SvREFCNT_dec(CvOUTSIDE(cv));
4300         CvOUTSIDE(cv) = NULL;
4301     }
4302     if (CvCONST(cv)) {
4303         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4304         CvCONST_off(cv);
4305     }
4306     if (CvISXSUB(cv) && CvXSUB(cv)) {
4307         CvXSUB(cv) = NULL;
4308     }
4309     /* delete all flags except WEAKOUTSIDE */
4310     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4311 }
4312
4313 void
4314 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4315 {
4316     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4317         SV* const msg = sv_newmortal();
4318         SV* name = NULL;
4319
4320         if (gv)
4321             gv_efullname3(name = sv_newmortal(), gv, NULL);
4322         sv_setpv(msg, "Prototype mismatch:");
4323         if (name)
4324             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4325         if (SvPOK(cv))
4326             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4327         else
4328             sv_catpvs(msg, ": none");
4329         sv_catpvs(msg, " vs ");
4330         if (p)
4331             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4332         else
4333             sv_catpvs(msg, "none");
4334         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4335     }
4336 }
4337
4338 static void const_sv_xsub(pTHX_ CV* cv);
4339
4340 /*
4341
4342 =head1 Optree Manipulation Functions
4343
4344 =for apidoc cv_const_sv
4345
4346 If C<cv> is a constant sub eligible for inlining. returns the constant
4347 value returned by the sub.  Otherwise, returns NULL.
4348
4349 Constant subs can be created with C<newCONSTSUB> or as described in
4350 L<perlsub/"Constant Functions">.
4351
4352 =cut
4353 */
4354 SV *
4355 Perl_cv_const_sv(pTHX_ CV *cv)
4356 {
4357     PERL_UNUSED_CONTEXT;
4358     if (!cv)
4359         return NULL;
4360     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4361         return NULL;
4362     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4363 }
4364
4365 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4366  * Can be called in 3 ways:
4367  *
4368  * !cv
4369  *      look for a single OP_CONST with attached value: return the value
4370  *
4371  * cv && CvCLONE(cv) && !CvCONST(cv)
4372  *
4373  *      examine the clone prototype, and if contains only a single
4374  *      OP_CONST referencing a pad const, or a single PADSV referencing
4375  *      an outer lexical, return a non-zero value to indicate the CV is
4376  *      a candidate for "constizing" at clone time
4377  *
4378  * cv && CvCONST(cv)
4379  *
4380  *      We have just cloned an anon prototype that was marked as a const
4381  *      candidiate. Try to grab the current value, and in the case of
4382  *      PADSV, ignore it if it has multiple references. Return the value.
4383  */
4384
4385 SV *
4386 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4387 {
4388     dVAR;
4389     SV *sv = NULL;
4390
4391     if (!o)
4392         return NULL;
4393
4394     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4395         o = cLISTOPo->op_first->op_sibling;
4396
4397     for (; o; o = o->op_next) {
4398         const OPCODE type = o->op_type;
4399
4400         if (sv && o->op_next == o)
4401             return sv;
4402         if (o->op_next != o) {
4403             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4404                 continue;
4405             if (type == OP_DBSTATE)
4406                 continue;
4407         }
4408         if (type == OP_LEAVESUB || type == OP_RETURN)
4409             break;
4410         if (sv)
4411             return NULL;
4412         if (type == OP_CONST && cSVOPo->op_sv)
4413             sv = cSVOPo->op_sv;
4414         else if (cv && type == OP_CONST) {
4415             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4416             if (!sv)
4417                 return NULL;
4418         }
4419         else if (cv && type == OP_PADSV) {
4420             if (CvCONST(cv)) { /* newly cloned anon */
4421                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4422                 /* the candidate should have 1 ref from this pad and 1 ref
4423                  * from the parent */
4424                 if (!sv || SvREFCNT(sv) != 2)
4425                     return NULL;
4426                 sv = newSVsv(sv);
4427                 SvREADONLY_on(sv);
4428                 return sv;
4429             }
4430             else {
4431                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4432                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4433             }
4434         }
4435         else {
4436             return NULL;
4437         }
4438     }
4439     return sv;
4440 }
4441
4442 void
4443 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4444 {
4445     PERL_UNUSED_ARG(floor);
4446
4447     if (o)
4448         SAVEFREEOP(o);
4449     if (proto)
4450         SAVEFREEOP(proto);
4451     if (attrs)
4452         SAVEFREEOP(attrs);
4453     if (block)
4454         SAVEFREEOP(block);
4455     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4456 }
4457
4458 CV *
4459 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4460 {
4461     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4462 }
4463
4464 CV *
4465 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4466 {
4467     dVAR;
4468     const char *aname;
4469     GV *gv;
4470     const char *ps;
4471     STRLEN ps_len;
4472     register CV *cv = NULL;
4473     SV *const_sv;
4474     /* If the subroutine has no body, no attributes, and no builtin attributes
4475        then it's just a sub declaration, and we may be able to get away with
4476        storing with a placeholder scalar in the symbol table, rather than a
4477        full GV and CV.  If anything is present then it will take a full CV to
4478        store it.  */
4479     const I32 gv_fetch_flags
4480         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4481         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4482     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4483
4484     if (proto) {
4485         assert(proto->op_type == OP_CONST);
4486         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4487     }
4488     else
4489         ps = NULL;
4490
4491     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4492         SV * const sv = sv_newmortal();
4493         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4494                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4495                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4496         aname = SvPVX_const(sv);
4497     }
4498     else
4499         aname = NULL;
4500
4501     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4502         : gv_fetchpv(aname ? aname
4503                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4504                      gv_fetch_flags, SVt_PVCV);
4505
4506     if (o)
4507         SAVEFREEOP(o);
4508     if (proto)
4509         SAVEFREEOP(proto);
4510     if (attrs)
4511         SAVEFREEOP(attrs);
4512
4513     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4514                                            maximum a prototype before. */
4515         if (SvTYPE(gv) > SVt_NULL) {
4516             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4517                 && ckWARN_d(WARN_PROTOTYPE))
4518             {
4519                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4520             }
4521             cv_ckproto((CV*)gv, NULL, ps);
4522         }
4523         if (ps)
4524             sv_setpvn((SV*)gv, ps, ps_len);
4525         else
4526             sv_setiv((SV*)gv, -1);
4527         SvREFCNT_dec(PL_compcv);
4528         cv = PL_compcv = NULL;
4529         PL_sub_generation++;
4530         goto done;
4531     }
4532
4533     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4534
4535 #ifdef GV_UNIQUE_CHECK
4536     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4537         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4538     }
4539 #endif
4540
4541     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4542         const_sv = NULL;
4543     else
4544         const_sv = op_const_sv(block, NULL);
4545
4546     if (cv) {
4547         const bool exists = CvROOT(cv) || CvXSUB(cv);
4548
4549 #ifdef GV_UNIQUE_CHECK
4550         if (exists && GvUNIQUE(gv)) {
4551             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4552         }
4553 #endif
4554
4555         /* if the subroutine doesn't exist and wasn't pre-declared
4556          * with a prototype, assume it will be AUTOLOADed,
4557          * skipping the prototype check
4558          */
4559         if (exists || SvPOK(cv))
4560             cv_ckproto(cv, gv, ps);
4561         /* already defined (or promised)? */
4562         if (exists || GvASSUMECV(gv)) {
4563             if (!block && !attrs) {
4564                 if (CvFLAGS(PL_compcv)) {
4565                     /* might have had built-in attrs applied */
4566                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4567                 }
4568                 /* just a "sub foo;" when &foo is already defined */
4569                 SAVEFREESV(PL_compcv);
4570                 goto done;
4571             }
4572             if (block) {
4573                 if (ckWARN(WARN_REDEFINE)
4574                     || (CvCONST(cv)
4575                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4576                 {
4577                     const line_t oldline = CopLINE(PL_curcop);
4578                     if (PL_copline != NOLINE)
4579                         CopLINE_set(PL_curcop, PL_copline);
4580                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4581                         CvCONST(cv) ? "Constant subroutine %s redefined"
4582                                     : "Subroutine %s redefined", name);
4583                     CopLINE_set(PL_curcop, oldline);
4584                 }
4585                 SvREFCNT_dec(cv);
4586                 cv = NULL;
4587             }
4588         }
4589     }
4590     if (const_sv) {
4591         SvREFCNT_inc_void_NN(const_sv);
4592         if (cv) {
4593             assert(!CvROOT(cv) && !CvCONST(cv));
4594             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4595             CvXSUBANY(cv).any_ptr = const_sv;
4596             CvXSUB(cv) = const_sv_xsub;
4597             CvCONST_on(cv);
4598             CvISXSUB_on(cv);
4599         }
4600         else {
4601             GvCV(gv) = NULL;
4602             cv = newCONSTSUB(NULL, name, const_sv);
4603         }
4604         op_free(block);
4605         SvREFCNT_dec(PL_compcv);
4606         PL_compcv = NULL;
4607         PL_sub_generation++;
4608         goto done;
4609     }
4610     if (attrs) {
4611         HV *stash;
4612         SV *rcv;
4613
4614         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4615          * before we clobber PL_compcv.
4616          */
4617         if (cv && !block) {
4618             rcv = (SV*)cv;
4619             /* Might have had built-in attributes applied -- propagate them. */
4620             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4621             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4622                 stash = GvSTASH(CvGV(cv));
4623             else if (CvSTASH(cv))
4624                 stash = CvSTASH(cv);
4625             else
4626                 stash = PL_curstash;
4627         }
4628         else {
4629             /* possibly about to re-define existing subr -- ignore old cv */
4630             rcv = (SV*)PL_compcv;
4631             if (name && GvSTASH(gv))
4632                 stash = GvSTASH(gv);
4633             else
4634                 stash = PL_curstash;
4635         }
4636         apply_attrs(stash, rcv, attrs, FALSE);
4637     }
4638     if (cv) {                           /* must reuse cv if autoloaded */
4639         if (!block) {
4640             /* got here with just attrs -- work done, so bug out */
4641             SAVEFREESV(PL_compcv);
4642             goto done;
4643         }
4644         /* transfer PL_compcv to cv */
4645         cv_undef(cv);
4646         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4647         if (!CvWEAKOUTSIDE(cv))
4648             SvREFCNT_dec(CvOUTSIDE(cv));
4649         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4650         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4651         CvOUTSIDE(PL_compcv) = 0;
4652         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4653         CvPADLIST(PL_compcv) = 0;
4654         /* inner references to PL_compcv must be fixed up ... */
4655         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4656         /* ... before we throw it away */
4657         SvREFCNT_dec(PL_compcv);
4658         PL_compcv = cv;
4659         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4660           ++PL_sub_generation;
4661     }
4662     else {
4663         cv = PL_compcv;
4664         if (name) {
4665             GvCV(gv) = cv;
4666             GvCVGEN(gv) = 0;
4667             PL_sub_generation++;
4668         }
4669     }
4670     CvGV(cv) = gv;
4671     CvFILE_set_from_cop(cv, PL_curcop);
4672     CvSTASH(cv) = PL_curstash;
4673
4674     if (ps)
4675         sv_setpvn((SV*)cv, ps, ps_len);
4676
4677     if (PL_error_count) {
4678         op_free(block);
4679         block = NULL;
4680         if (name) {
4681             const char *s = strrchr(name, ':');
4682             s = s ? s+1 : name;
4683             if (strEQ(s, "BEGIN")) {
4684                 const char not_safe[] =
4685                     "BEGIN not safe after errors--compilation aborted";
4686                 if (PL_in_eval & EVAL_KEEPERR)
4687                     Perl_croak(aTHX_ not_safe);
4688                 else {
4689                     /* force display of errors found but not reported */
4690                     sv_catpv(ERRSV, not_safe);
4691                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4692                 }
4693             }
4694         }
4695     }
4696     if (!block)
4697         goto done;
4698
4699     if (CvLVALUE(cv)) {
4700         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4701                              mod(scalarseq(block), OP_LEAVESUBLV));
4702     }
4703     else {
4704         /* This makes sub {}; work as expected.  */
4705         if (block->op_type == OP_STUB) {
4706             op_free(block);
4707             block = newSTATEOP(0, NULL, 0);
4708         }
4709         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4710     }
4711     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4712     OpREFCNT_set(CvROOT(cv), 1);
4713     CvSTART(cv) = LINKLIST(CvROOT(cv));
4714     CvROOT(cv)->op_next = 0;
4715     CALL_PEEP(CvSTART(cv));
4716
4717     /* now that optimizer has done its work, adjust pad values */
4718
4719     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4720
4721     if (CvCLONE(cv)) {
4722         assert(!CvCONST(cv));
4723         if (ps && !*ps && op_const_sv(block, cv))
4724             CvCONST_on(cv);
4725     }
4726
4727     if (name || aname) {
4728         const char *s;
4729         const char * const tname = (name ? name : aname);
4730
4731         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4732             SV * const sv = newSV(0);
4733             SV * const tmpstr = sv_newmortal();
4734             GV * const db_postponed = gv_fetchpvs("DB::postponed",
4735                                                   GV_ADDMULTI, SVt_PVHV);
4736             HV *hv;
4737
4738             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4739                            CopFILE(PL_curcop),
4740                            (long)PL_subline, (long)CopLINE(PL_curcop));
4741             gv_efullname3(tmpstr, gv, NULL);
4742             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4743             hv = GvHVn(db_postponed);
4744             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4745                 CV * const pcv = GvCV(db_postponed);
4746                 if (pcv) {
4747                     dSP;
4748                     PUSHMARK(SP);
4749                     XPUSHs(tmpstr);
4750                     PUTBACK;
4751                     call_sv((SV*)pcv, G_DISCARD);
4752                 }
4753             }
4754         }
4755
4756         if ((s = strrchr(tname,':')))
4757             s++;
4758         else
4759             s = tname;
4760
4761         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4762             goto done;
4763
4764         if (strEQ(s, "BEGIN") && !PL_error_count) {
4765             const I32 oldscope = PL_scopestack_ix;
4766             ENTER;
4767             SAVECOPFILE(&PL_compiling);
4768             SAVECOPLINE(&PL_compiling);
4769
4770             if (!PL_beginav)
4771                 PL_beginav = newAV();
4772             DEBUG_x( dump_sub(gv) );
4773             av_push(PL_beginav, (SV*)cv);
4774             GvCV(gv) = 0;               /* cv has been hijacked */
4775             call_list(oldscope, PL_beginav);
4776
4777             PL_curcop = &PL_compiling;
4778             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4779             LEAVE;
4780         }
4781         else if (strEQ(s, "END") && !PL_error_count) {
4782             if (!PL_endav)
4783                 PL_endav = newAV();
4784             DEBUG_x( dump_sub(gv) );
4