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