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