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