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