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