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