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