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