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