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