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