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