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