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