This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #27040] - hints hash was being double freed on scope exit
[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             op_free(first);
3373             *firstp = Nullop;
3374             other->op_private |= OPpCONST_SHORTCIRCUIT;
3375             return other;
3376         }
3377         else {
3378             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3379             OP *o2 = other;
3380             if ( ! (o2->op_type == OP_LIST
3381                     && (( o2 = cUNOPx(o2)->op_first))
3382                     && o2->op_type == OP_PUSHMARK
3383                     && (( o2 = o2->op_sibling)) )
3384             )
3385                 o2 = other;
3386             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3387                         || o2->op_type == OP_PADHV)
3388                 && o2->op_private & OPpLVAL_INTRO
3389                 && ckWARN(WARN_DEPRECATED))
3390             {
3391                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3392                             "Deprecated use of my() in false conditional");
3393             }
3394
3395             op_free(other);
3396             *otherp = Nullop;
3397             first->op_private |= OPpCONST_SHORTCIRCUIT;
3398             return first;
3399         }
3400     }
3401     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3402              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3403     {
3404         OP *k1 = ((UNOP*)first)->op_first;
3405         OP *k2 = k1->op_sibling;
3406         OPCODE warnop = 0;
3407         switch (first->op_type)
3408         {
3409         case OP_NULL:
3410             if (k2 && k2->op_type == OP_READLINE
3411                   && (k2->op_flags & OPf_STACKED)
3412                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3413             {
3414                 warnop = k2->op_type;
3415             }
3416             break;
3417
3418         case OP_SASSIGN:
3419             if (k1->op_type == OP_READDIR
3420                   || k1->op_type == OP_GLOB
3421                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3422                   || k1->op_type == OP_EACH)
3423             {
3424                 warnop = ((k1->op_type == OP_NULL)
3425                           ? (OPCODE)k1->op_targ : k1->op_type);
3426             }
3427             break;
3428         }
3429         if (warnop) {
3430             line_t oldline = CopLINE(PL_curcop);
3431             CopLINE_set(PL_curcop, PL_copline);
3432             Perl_warner(aTHX_ packWARN(WARN_MISC),
3433                  "Value of %s%s can be \"0\"; test with defined()",
3434                  PL_op_desc[warnop],
3435                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3436                   ? " construct" : "() operator"));
3437             CopLINE_set(PL_curcop, oldline);
3438         }
3439     }
3440
3441     if (!other)
3442         return first;
3443
3444     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3445         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3446
3447     NewOp(1101, logop, 1, LOGOP);
3448
3449     logop->op_type = (OPCODE)type;
3450     logop->op_ppaddr = PL_ppaddr[type];
3451     logop->op_first = first;
3452     logop->op_flags = flags | OPf_KIDS;
3453     logop->op_other = LINKLIST(other);
3454     logop->op_private = (U8)(1 | (flags >> 8));
3455
3456     /* establish postfix order */
3457     logop->op_next = LINKLIST(first);
3458     first->op_next = (OP*)logop;
3459     first->op_sibling = other;
3460
3461     CHECKOP(type,logop);
3462
3463     o = newUNOP(OP_NULL, 0, (OP*)logop);
3464     other->op_next = o;
3465
3466     return o;
3467 }
3468
3469 OP *
3470 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3471 {
3472     LOGOP *logop;
3473     OP *start;
3474     OP *o;
3475
3476     if (!falseop)
3477         return newLOGOP(OP_AND, 0, first, trueop);
3478     if (!trueop)
3479         return newLOGOP(OP_OR, 0, first, falseop);
3480
3481     scalarboolean(first);
3482     if (first->op_type == OP_CONST) {
3483         if (first->op_private & OPpCONST_BARE &&
3484            first->op_private & OPpCONST_STRICT) {
3485            no_bareword_allowed(first);
3486        }
3487         if (SvTRUE(((SVOP*)first)->op_sv)) {
3488             op_free(first);
3489             op_free(falseop);
3490             return trueop;
3491         }
3492         else {
3493             op_free(first);
3494             op_free(trueop);
3495             return falseop;
3496         }
3497     }
3498     NewOp(1101, logop, 1, LOGOP);
3499     logop->op_type = OP_COND_EXPR;
3500     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3501     logop->op_first = first;
3502     logop->op_flags = flags | OPf_KIDS;
3503     logop->op_private = (U8)(1 | (flags >> 8));
3504     logop->op_other = LINKLIST(trueop);
3505     logop->op_next = LINKLIST(falseop);
3506
3507     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3508             logop);
3509
3510     /* establish postfix order */
3511     start = LINKLIST(first);
3512     first->op_next = (OP*)logop;
3513
3514     first->op_sibling = trueop;
3515     trueop->op_sibling = falseop;
3516     o = newUNOP(OP_NULL, 0, (OP*)logop);
3517
3518     trueop->op_next = falseop->op_next = o;
3519
3520     o->op_next = start;
3521     return o;
3522 }
3523
3524 OP *
3525 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3526 {
3527     LOGOP *range;
3528     OP *flip;
3529     OP *flop;
3530     OP *leftstart;
3531     OP *o;
3532
3533     NewOp(1101, range, 1, LOGOP);
3534
3535     range->op_type = OP_RANGE;
3536     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3537     range->op_first = left;
3538     range->op_flags = OPf_KIDS;
3539     leftstart = LINKLIST(left);
3540     range->op_other = LINKLIST(right);
3541     range->op_private = (U8)(1 | (flags >> 8));
3542
3543     left->op_sibling = right;
3544
3545     range->op_next = (OP*)range;
3546     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3547     flop = newUNOP(OP_FLOP, 0, flip);
3548     o = newUNOP(OP_NULL, 0, flop);
3549     linklist(flop);
3550     range->op_next = leftstart;
3551
3552     left->op_next = flip;
3553     right->op_next = flop;
3554
3555     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3556     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3557     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3558     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3559
3560     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3561     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3562
3563     flip->op_next = o;
3564     if (!flip->op_private || !flop->op_private)
3565         linklist(o);            /* blow off optimizer unless constant */
3566
3567     return o;
3568 }
3569
3570 OP *
3571 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3572 {
3573     OP* listop;
3574     OP* o;
3575     int once = block && block->op_flags & OPf_SPECIAL &&
3576       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3577
3578     if (expr) {
3579         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3580             return block;       /* do {} while 0 does once */
3581         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3582             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3583             expr = newUNOP(OP_DEFINED, 0,
3584                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3585         } else if (expr->op_flags & OPf_KIDS) {
3586             OP *k1 = ((UNOP*)expr)->op_first;
3587             OP *k2 = (k1) ? k1->op_sibling : NULL;
3588             switch (expr->op_type) {
3589               case OP_NULL:
3590                 if (k2 && k2->op_type == OP_READLINE
3591                       && (k2->op_flags & OPf_STACKED)
3592                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3593                     expr = newUNOP(OP_DEFINED, 0, expr);
3594                 break;
3595
3596               case OP_SASSIGN:
3597                 if (k1->op_type == OP_READDIR
3598                       || k1->op_type == OP_GLOB
3599                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3600                       || k1->op_type == OP_EACH)
3601                     expr = newUNOP(OP_DEFINED, 0, expr);
3602                 break;
3603             }
3604         }
3605     }
3606
3607     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3608      * op, in listop. This is wrong. [perl #27024] */
3609     if (!block)
3610         block = newOP(OP_NULL, 0);
3611     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3612     o = new_logop(OP_AND, 0, &expr, &listop);
3613
3614     if (listop)
3615         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3616
3617     if (once && o != listop)
3618         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3619
3620     if (o == listop)
3621         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3622
3623     o->op_flags |= flags;
3624     o = scope(o);
3625     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3626     return o;
3627 }
3628
3629 OP *
3630 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3631 {
3632     OP *redo;
3633     OP *next = 0;
3634     OP *listop;
3635     OP *o;
3636     U8 loopflags = 0;
3637
3638     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3639                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3640         expr = newUNOP(OP_DEFINED, 0,
3641             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3642     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3643         OP *k1 = ((UNOP*)expr)->op_first;
3644         OP *k2 = (k1) ? k1->op_sibling : NULL;
3645         switch (expr->op_type) {
3646           case OP_NULL:
3647             if (k2 && k2->op_type == OP_READLINE
3648                   && (k2->op_flags & OPf_STACKED)
3649                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3650                 expr = newUNOP(OP_DEFINED, 0, expr);
3651             break;
3652
3653           case OP_SASSIGN:
3654             if (k1->op_type == OP_READDIR
3655                   || k1->op_type == OP_GLOB
3656                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3657                   || k1->op_type == OP_EACH)
3658                 expr = newUNOP(OP_DEFINED, 0, expr);
3659             break;
3660         }
3661     }
3662
3663     if (!block)
3664         block = newOP(OP_NULL, 0);
3665     else if (cont) {
3666         block = scope(block);
3667     }
3668
3669     if (cont) {
3670         next = LINKLIST(cont);
3671     }
3672     if (expr) {
3673         OP *unstack = newOP(OP_UNSTACK, 0);
3674         if (!next)
3675             next = unstack;
3676         cont = append_elem(OP_LINESEQ, cont, unstack);
3677     }
3678
3679     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3680     redo = LINKLIST(listop);
3681
3682     if (expr) {
3683         PL_copline = (line_t)whileline;
3684         scalar(listop);
3685         o = new_logop(OP_AND, 0, &expr, &listop);
3686         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3687             op_free(expr);              /* oops, it's a while (0) */
3688             op_free((OP*)loop);
3689             return Nullop;              /* listop already freed by new_logop */
3690         }
3691         if (listop)
3692             ((LISTOP*)listop)->op_last->op_next =
3693                 (o == listop ? redo : LINKLIST(o));
3694     }
3695     else
3696         o = listop;
3697
3698     if (!loop) {
3699         NewOp(1101,loop,1,LOOP);
3700         loop->op_type = OP_ENTERLOOP;
3701         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3702         loop->op_private = 0;
3703         loop->op_next = (OP*)loop;
3704     }
3705
3706     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3707
3708     loop->op_redoop = redo;
3709     loop->op_lastop = o;
3710     o->op_private |= loopflags;
3711
3712     if (next)
3713         loop->op_nextop = next;
3714     else
3715         loop->op_nextop = o;
3716
3717     o->op_flags |= flags;
3718     o->op_private |= (flags >> 8);
3719     return o;
3720 }
3721
3722 OP *
3723 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3724 {
3725     LOOP *loop;
3726     OP *wop;
3727     PADOFFSET padoff = 0;
3728     I32 iterflags = 0;
3729     I32 iterpflags = 0;
3730
3731     if (sv) {
3732         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3733             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3734             sv->op_type = OP_RV2GV;
3735             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3736         }
3737         else if (sv->op_type == OP_PADSV) { /* private variable */
3738             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3739             padoff = sv->op_targ;
3740             sv->op_targ = 0;
3741             op_free(sv);
3742             sv = Nullop;
3743         }
3744         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3745             padoff = sv->op_targ;
3746             sv->op_targ = 0;
3747             iterflags |= OPf_SPECIAL;
3748             op_free(sv);
3749             sv = Nullop;
3750         }
3751         else
3752             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3753     }
3754     else {
3755         I32 offset = pad_findmy("$_");
3756         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3757             sv = newGVOP(OP_GV, 0, PL_defgv);
3758         }
3759         else {
3760             padoff = offset;
3761         }
3762     }
3763     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3764         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3765         iterflags |= OPf_STACKED;
3766     }
3767     else if (expr->op_type == OP_NULL &&
3768              (expr->op_flags & OPf_KIDS) &&
3769              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3770     {
3771         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3772          * set the STACKED flag to indicate that these values are to be
3773          * treated as min/max values by 'pp_iterinit'.
3774          */
3775         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3776         LOGOP* range = (LOGOP*) flip->op_first;
3777         OP* left  = range->op_first;
3778         OP* right = left->op_sibling;
3779         LISTOP* listop;
3780
3781         range->op_flags &= ~OPf_KIDS;
3782         range->op_first = Nullop;
3783
3784         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3785         listop->op_first->op_next = range->op_next;
3786         left->op_next = range->op_other;
3787         right->op_next = (OP*)listop;
3788         listop->op_next = listop->op_first;
3789
3790         op_free(expr);
3791         expr = (OP*)(listop);
3792         op_null(expr);
3793         iterflags |= OPf_STACKED;
3794     }
3795     else {
3796         expr = mod(force_list(expr), OP_GREPSTART);
3797     }
3798
3799
3800     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3801                                append_elem(OP_LIST, expr, scalar(sv))));
3802     assert(!loop->op_next);
3803     /* for my  $x () sets OPpLVAL_INTRO;
3804      * for our $x () sets OPpOUR_INTRO */
3805     loop->op_private = (U8)iterpflags;
3806 #ifdef PL_OP_SLAB_ALLOC
3807     {
3808         LOOP *tmp;
3809         NewOp(1234,tmp,1,LOOP);
3810         Copy(loop,tmp,1,LOOP);
3811         FreeOp(loop);
3812         loop = tmp;
3813     }
3814 #else
3815     Renew(loop, 1, LOOP);
3816 #endif
3817     loop->op_targ = padoff;
3818     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3819     PL_copline = forline;
3820     return newSTATEOP(0, label, wop);
3821 }
3822
3823 OP*
3824 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3825 {
3826     OP *o;
3827     STRLEN n_a;
3828
3829     if (type != OP_GOTO || label->op_type == OP_CONST) {
3830         /* "last()" means "last" */
3831         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3832             o = newOP(type, OPf_SPECIAL);
3833         else {
3834             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3835                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3836                                         : ""));
3837         }
3838         op_free(label);
3839     }
3840     else {
3841         /* Check whether it's going to be a goto &function */
3842         if (label->op_type == OP_ENTERSUB
3843                 && !(label->op_flags & OPf_STACKED))
3844             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3845         o = newUNOP(type, OPf_STACKED, label);
3846     }
3847     PL_hints |= HINT_BLOCK_SCOPE;
3848     return o;
3849 }
3850
3851 /*
3852 =for apidoc cv_undef
3853
3854 Clear out all the active components of a CV. This can happen either
3855 by an explicit C<undef &foo>, or by the reference count going to zero.
3856 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3857 children can still follow the full lexical scope chain.
3858
3859 =cut
3860 */
3861
3862 void
3863 Perl_cv_undef(pTHX_ CV *cv)
3864 {
3865 #ifdef USE_ITHREADS
3866     if (CvFILE(cv) && !CvXSUB(cv)) {
3867         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3868         Safefree(CvFILE(cv));
3869     }
3870     CvFILE(cv) = 0;
3871 #endif
3872
3873     if (!CvXSUB(cv) && CvROOT(cv)) {
3874         if (CvDEPTH(cv))
3875             Perl_croak(aTHX_ "Can't undef active subroutine");
3876         ENTER;
3877
3878         PAD_SAVE_SETNULLPAD();
3879
3880         op_free(CvROOT(cv));
3881         CvROOT(cv) = Nullop;
3882         LEAVE;
3883     }
3884     SvPOK_off((SV*)cv);         /* forget prototype */
3885     CvGV(cv) = Nullgv;
3886
3887     pad_undef(cv);
3888
3889     /* remove CvOUTSIDE unless this is an undef rather than a free */
3890     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3891         if (!CvWEAKOUTSIDE(cv))
3892             SvREFCNT_dec(CvOUTSIDE(cv));
3893         CvOUTSIDE(cv) = Nullcv;
3894     }
3895     if (CvCONST(cv)) {
3896         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3897         CvCONST_off(cv);
3898     }
3899     if (CvXSUB(cv)) {
3900         CvXSUB(cv) = 0;
3901     }
3902     /* delete all flags except WEAKOUTSIDE */
3903     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3904 }
3905
3906 void
3907 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3908 {
3909     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3910         SV* msg = sv_newmortal();
3911         SV* name = Nullsv;
3912
3913         if (gv)
3914             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3915         sv_setpv(msg, "Prototype mismatch:");
3916         if (name)
3917             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3918         if (SvPOK(cv))
3919             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3920         else
3921             Perl_sv_catpvf(aTHX_ msg, ": none");
3922         sv_catpv(msg, " vs ");
3923         if (p)
3924             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3925         else
3926             sv_catpv(msg, "none");
3927         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3928     }
3929 }
3930
3931 static void const_sv_xsub(pTHX_ CV* cv);
3932
3933 /*
3934
3935 =head1 Optree Manipulation Functions
3936
3937 =for apidoc cv_const_sv
3938
3939 If C<cv> is a constant sub eligible for inlining. returns the constant
3940 value returned by the sub.  Otherwise, returns NULL.
3941
3942 Constant subs can be created with C<newCONSTSUB> or as described in
3943 L<perlsub/"Constant Functions">.
3944
3945 =cut
3946 */
3947 SV *
3948 Perl_cv_const_sv(pTHX_ CV *cv)
3949 {
3950     if (!cv || !CvCONST(cv))
3951         return Nullsv;
3952     return (SV*)CvXSUBANY(cv).any_ptr;
3953 }
3954
3955 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3956  * Can be called in 3 ways:
3957  *
3958  * !cv
3959  *      look for a single OP_CONST with attached value: return the value
3960  *
3961  * cv && CvCLONE(cv) && !CvCONST(cv)
3962  *
3963  *      examine the clone prototype, and if contains only a single
3964  *      OP_CONST referencing a pad const, or a single PADSV referencing
3965  *      an outer lexical, return a non-zero value to indicate the CV is
3966  *      a candidate for "constizing" at clone time
3967  *
3968  * cv && CvCONST(cv)
3969  *
3970  *      We have just cloned an anon prototype that was marked as a const
3971  *      candidiate. Try to grab the current value, and in the case of
3972  *      PADSV, ignore it if it has multiple references. Return the value.
3973  */
3974
3975 SV *
3976 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3977 {
3978     SV *sv = Nullsv;
3979
3980     if (!o)
3981         return Nullsv;
3982
3983     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3984         o = cLISTOPo->op_first->op_sibling;
3985
3986     for (; o; o = o->op_next) {
3987         OPCODE type = o->op_type;
3988
3989         if (sv && o->op_next == o)
3990             return sv;
3991         if (o->op_next != o) {
3992             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3993                 continue;
3994             if (type == OP_DBSTATE)
3995                 continue;
3996         }
3997         if (type == OP_LEAVESUB || type == OP_RETURN)
3998             break;
3999         if (sv)
4000             return Nullsv;
4001         if (type == OP_CONST && cSVOPo->op_sv)
4002             sv = cSVOPo->op_sv;
4003         else if (cv && type == OP_CONST) {
4004             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4005             if (!sv)
4006                 return Nullsv;
4007         }
4008         else if (cv && type == OP_PADSV) {
4009             if (CvCONST(cv)) { /* newly cloned anon */
4010                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4011                 /* the candidate should have 1 ref from this pad and 1 ref
4012                  * from the parent */
4013                 if (!sv || SvREFCNT(sv) != 2)
4014                     return Nullsv;
4015                 sv = newSVsv(sv);
4016                 SvREADONLY_on(sv);
4017                 return sv;
4018             }
4019             else {
4020                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4021                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4022             }
4023         }
4024         else {
4025             return Nullsv;
4026         }
4027     }
4028     return sv;
4029 }
4030
4031 void
4032 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4033 {
4034     if (o)
4035         SAVEFREEOP(o);
4036     if (proto)
4037         SAVEFREEOP(proto);
4038     if (attrs)
4039         SAVEFREEOP(attrs);
4040     if (block)
4041         SAVEFREEOP(block);
4042     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4043 }
4044
4045 CV *
4046 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4047 {
4048     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4049 }
4050
4051 CV *
4052 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4053 {
4054     STRLEN n_a;
4055     char *name;
4056     char *aname;
4057     GV *gv;
4058     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4059     register CV *cv=0;
4060     SV *const_sv;
4061
4062     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4063     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4064         SV *sv = sv_newmortal();
4065         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4066                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4067                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4068         aname = SvPVX(sv);
4069     }
4070     else
4071         aname = Nullch;
4072     gv = gv_fetchpv(name ? name : (aname ? aname : 
4073                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4074                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4075                     SVt_PVCV);
4076
4077     if (o)
4078         SAVEFREEOP(o);
4079     if (proto)
4080         SAVEFREEOP(proto);
4081     if (attrs)
4082         SAVEFREEOP(attrs);
4083
4084     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4085                                            maximum a prototype before. */
4086         if (SvTYPE(gv) > SVt_NULL) {
4087             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4088                 && ckWARN_d(WARN_PROTOTYPE))
4089             {
4090                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4091             }
4092             cv_ckproto((CV*)gv, NULL, ps);
4093         }
4094         if (ps)
4095             sv_setpv((SV*)gv, ps);
4096         else
4097             sv_setiv((SV*)gv, -1);
4098         SvREFCNT_dec(PL_compcv);
4099         cv = PL_compcv = NULL;
4100         PL_sub_generation++;
4101         goto done;
4102     }
4103
4104     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4105
4106 #ifdef GV_UNIQUE_CHECK
4107     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4108         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4109     }
4110 #endif
4111
4112     if (!block || !ps || *ps || attrs)
4113         const_sv = Nullsv;
4114     else
4115         const_sv = op_const_sv(block, Nullcv);
4116
4117     if (cv) {
4118         bool exists = CvROOT(cv) || CvXSUB(cv);
4119
4120 #ifdef GV_UNIQUE_CHECK
4121         if (exists && GvUNIQUE(gv)) {
4122             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4123         }
4124 #endif
4125
4126         /* if the subroutine doesn't exist and wasn't pre-declared
4127          * with a prototype, assume it will be AUTOLOADed,
4128          * skipping the prototype check
4129          */
4130         if (exists || SvPOK(cv))
4131             cv_ckproto(cv, gv, ps);
4132         /* already defined (or promised)? */
4133         if (exists || GvASSUMECV(gv)) {
4134             if (!block && !attrs) {
4135                 if (CvFLAGS(PL_compcv)) {
4136                     /* might have had built-in attrs applied */
4137                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4138                 }
4139                 /* just a "sub foo;" when &foo is already defined */
4140                 SAVEFREESV(PL_compcv);
4141                 goto done;
4142             }
4143             /* ahem, death to those who redefine active sort subs */
4144             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4145                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4146             if (block) {
4147                 if (ckWARN(WARN_REDEFINE)
4148                     || (CvCONST(cv)
4149                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4150                 {
4151                     line_t oldline = CopLINE(PL_curcop);
4152                     if (PL_copline != NOLINE)
4153                         CopLINE_set(PL_curcop, PL_copline);
4154                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4155                         CvCONST(cv) ? "Constant subroutine %s redefined"
4156                                     : "Subroutine %s redefined", name);
4157                     CopLINE_set(PL_curcop, oldline);
4158                 }
4159                 SvREFCNT_dec(cv);
4160                 cv = Nullcv;
4161             }
4162         }
4163     }
4164     if (const_sv) {
4165         SvREFCNT_inc(const_sv);
4166         if (cv) {
4167             assert(!CvROOT(cv) && !CvCONST(cv));
4168             sv_setpv((SV*)cv, "");  /* prototype is "" */
4169             CvXSUBANY(cv).any_ptr = const_sv;
4170             CvXSUB(cv) = const_sv_xsub;
4171             CvCONST_on(cv);
4172         }
4173         else {
4174             GvCV(gv) = Nullcv;
4175             cv = newCONSTSUB(NULL, name, const_sv);
4176         }
4177         op_free(block);
4178         SvREFCNT_dec(PL_compcv);
4179         PL_compcv = NULL;
4180         PL_sub_generation++;
4181         goto done;
4182     }
4183     if (attrs) {
4184         HV *stash;
4185         SV *rcv;
4186
4187         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4188          * before we clobber PL_compcv.
4189          */
4190         if (cv && !block) {
4191             rcv = (SV*)cv;
4192             /* Might have had built-in attributes applied -- propagate them. */
4193             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4194             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4195                 stash = GvSTASH(CvGV(cv));
4196             else if (CvSTASH(cv))
4197                 stash = CvSTASH(cv);
4198             else
4199                 stash = PL_curstash;
4200         }
4201         else {
4202             /* possibly about to re-define existing subr -- ignore old cv */
4203             rcv = (SV*)PL_compcv;
4204             if (name && GvSTASH(gv))
4205                 stash = GvSTASH(gv);
4206             else
4207                 stash = PL_curstash;
4208         }
4209         apply_attrs(stash, rcv, attrs, FALSE);
4210     }
4211     if (cv) {                           /* must reuse cv if autoloaded */
4212         if (!block) {
4213             /* got here with just attrs -- work done, so bug out */
4214             SAVEFREESV(PL_compcv);
4215             goto done;
4216         }
4217         /* transfer PL_compcv to cv */
4218         cv_undef(cv);
4219         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4220         if (!CvWEAKOUTSIDE(cv))
4221             SvREFCNT_dec(CvOUTSIDE(cv));
4222         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4223         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4224         CvOUTSIDE(PL_compcv) = 0;
4225         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4226         CvPADLIST(PL_compcv) = 0;
4227         /* inner references to PL_compcv must be fixed up ... */
4228         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4229         /* ... before we throw it away */
4230         SvREFCNT_dec(PL_compcv);
4231         PL_compcv = cv;
4232         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4233           ++PL_sub_generation;
4234     }
4235     else {
4236         cv = PL_compcv;
4237         if (name) {
4238             GvCV(gv) = cv;
4239             GvCVGEN(gv) = 0;
4240             PL_sub_generation++;
4241         }
4242     }
4243     CvGV(cv) = gv;
4244     CvFILE_set_from_cop(cv, PL_curcop);
4245     CvSTASH(cv) = PL_curstash;
4246
4247     if (ps)
4248         sv_setpv((SV*)cv, ps);
4249
4250     if (PL_error_count) {
4251         op_free(block);
4252         block = Nullop;
4253         if (name) {
4254             char *s = strrchr(name, ':');
4255             s = s ? s+1 : name;
4256             if (strEQ(s, "BEGIN")) {
4257                 char *not_safe =
4258                     "BEGIN not safe after errors--compilation aborted";
4259                 if (PL_in_eval & EVAL_KEEPERR)
4260                     Perl_croak(aTHX_ not_safe);
4261                 else {
4262                     /* force display of errors found but not reported */
4263                     sv_catpv(ERRSV, not_safe);
4264                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4265                 }
4266             }
4267         }
4268     }
4269     if (!block)
4270         goto done;
4271
4272     if (CvLVALUE(cv)) {
4273         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4274                              mod(scalarseq(block), OP_LEAVESUBLV));
4275     }
4276     else {
4277         /* This makes sub {}; work as expected.  */
4278         if (block->op_type == OP_STUB) {
4279             op_free(block);
4280             block = newSTATEOP(0, Nullch, 0);
4281         }
4282         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4283     }
4284     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4285     OpREFCNT_set(CvROOT(cv), 1);
4286     CvSTART(cv) = LINKLIST(CvROOT(cv));
4287     CvROOT(cv)->op_next = 0;
4288     CALL_PEEP(CvSTART(cv));
4289
4290     /* now that optimizer has done its work, adjust pad values */
4291
4292     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4293
4294     if (CvCLONE(cv)) {
4295         assert(!CvCONST(cv));
4296         if (ps && !*ps && op_const_sv(block, cv))
4297             CvCONST_on(cv);
4298     }
4299
4300     if (name || aname) {
4301         char *s;
4302         char *tname = (name ? name : aname);
4303
4304         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4305             SV *sv = NEWSV(0,0);
4306             SV *tmpstr = sv_newmortal();
4307             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4308             CV *pcv;
4309             HV *hv;
4310
4311             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4312                            CopFILE(PL_curcop),
4313                            (long)PL_subline, (long)CopLINE(PL_curcop));
4314             gv_efullname3(tmpstr, gv, Nullch);
4315             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4316             hv = GvHVn(db_postponed);
4317             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4318                 && (pcv = GvCV(db_postponed)))
4319             {
4320                 dSP;
4321                 PUSHMARK(SP);
4322                 XPUSHs(tmpstr);
4323                 PUTBACK;
4324                 call_sv((SV*)pcv, G_DISCARD);
4325             }
4326         }
4327
4328         if ((s = strrchr(tname,':')))
4329             s++;
4330         else
4331             s = tname;
4332
4333         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4334             goto done;
4335
4336         if (strEQ(s, "BEGIN") && !PL_error_count) {
4337             I32 oldscope = PL_scopestack_ix;
4338             ENTER;
4339             SAVECOPFILE(&PL_compiling);
4340             SAVECOPLINE(&PL_compiling);
4341
4342             if (!PL_beginav)
4343                 PL_beginav = newAV();
4344             DEBUG_x( dump_sub(gv) );
4345             av_push(PL_beginav, (SV*)cv);
4346             GvCV(gv) = 0;               /* cv has been hijacked */
4347             call_list(oldscope, PL_beginav);
4348
4349             PL_curcop = &PL_compiling;
4350             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4351             LEAVE;
4352         }
4353         else if (strEQ(s, "END") && !PL_error_count) {
4354             if (!PL_endav)
4355                 PL_endav = newAV();
4356             DEBUG_x( dump_sub(gv) );
4357             av_unshift(PL_endav, 1);
4358             av_store(PL_endav, 0, (SV*)cv);
4359             GvCV(gv) = 0;               /* cv has been hijacked */
4360         }
4361         else if (strEQ(s, "CHECK") && !PL_error_count) {
4362             if (!PL_checkav)
4363                 PL_checkav = newAV();
4364             DEBUG_x( dump_sub(gv) );
4365             if (PL_main_start && ckWARN(WARN_VOID))
4366                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4367             av_unshift(PL_checkav, 1);
4368             av_store(PL_checkav, 0, (SV*)cv);
4369             GvCV(gv) = 0;               /* cv has been hijacked */
4370         }
4371         else if (strEQ(s, "INIT") && !PL_error_count) {
4372             if (!PL_initav)
4373                 PL_initav = newAV();
4374             DEBUG_x( dump_sub(gv) );
4375             if (PL_main_start && ckWARN(WARN_VOID))
4376                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4377             av_push(PL_initav, (SV*)cv);
4378             GvCV(gv) = 0;               /* cv has been hijacked */
4379         }
4380     }
4381
4382   done:
4383     PL_copline = NOLINE;
4384     LEAVE_SCOPE(floor);
4385     return cv;
4386 }
4387
4388 /* XXX unsafe for threads if eval_owner isn't held */
4389 /*
4390 =for apidoc newCONSTSUB
4391
4392 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4393 eligible for inlining at compile-time.
4394
4395 =cut
4396 */
4397
4398 CV *
4399 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4400 {
4401     CV* cv;
4402
4403     ENTER;
4404
4405     SAVECOPLINE(PL_curcop);
4406     CopLINE_set(PL_curcop, PL_copline);
4407
4408     SAVEHINTS();
4409     PL_hints &= ~HINT_BLOCK_SCOPE;
4410
4411     if (stash) {
4412         SAVESPTR(PL_curstash);
4413         SAVECOPSTASH(PL_curcop);
4414         PL_curstash = stash;
4415         CopSTASH_set(PL_curcop,stash);
4416     }
4417
4418     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4419     CvXSUBANY(cv).any_ptr = sv;
4420     CvCONST_on(cv);
4421     sv_setpv((SV*)cv, "");  /* prototype is "" */
4422
4423     if (stash)
4424         CopSTASH_free(PL_curcop);
4425
4426     LEAVE;
4427
4428     return cv;
4429 }
4430
4431 /*
4432 =for apidoc U||newXS
4433
4434 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4435
4436 =cut
4437 */
4438
4439 CV *
4440 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4441 {
4442     GV *gv = gv_fetchpv(name ? name :
4443                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4444                         GV_ADDMULTI, SVt_PVCV);
4445     register CV *cv;
4446
4447     if (!subaddr)
4448         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4449
4450     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4451         if (GvCVGEN(gv)) {
4452             /* just a cached method */
4453             SvREFCNT_dec(cv);
4454             cv = 0;
4455         }
4456         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4457             /* already defined (or promised) */
4458             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4459                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4460                 line_t oldline = CopLINE(PL_curcop);
4461                 if (PL_copline != NOLINE)
4462                     CopLINE_set(PL_curcop, PL_copline);
4463                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4464                             CvCONST(cv) ? "Constant subroutine %s redefined"
4465                                         : "Subroutine %s redefined"
4466                             ,name);
4467                 CopLINE_set(PL_curcop, oldline);
4468             }
4469             SvREFCNT_dec(cv);
4470             cv = 0;
4471         }
4472     }
4473
4474     if (cv)                             /* must reuse cv if autoloaded */
4475         cv_undef(cv);
4476     else {
4477         cv = (CV*)NEWSV(1105,0);
4478         sv_upgrade((SV *)cv, SVt_PVCV);
4479         if (name) {
4480             GvCV(gv) = cv;
4481             GvCVGEN(gv) = 0;
4482             PL_sub_generation++;
4483         }
4484     }
4485     CvGV(cv) = gv;
4486     (void)gv_fetchfile(filename);
4487     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4488                                    an external constant string */
4489     CvXSUB(cv) = subaddr;
4490
4491     if (name) {
4492         char *s = strrchr(name,':');
4493         if (s)
4494             s++;
4495         else
4496             s = name;
4497
4498         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4499             goto done;
4500
4501         if (strEQ(s, "BEGIN")) {
4502             if (!PL_beginav)
4503                 PL_beginav = newAV();
4504             av_push(PL_beginav, (SV*)cv);
4505             GvCV(gv) = 0;               /* cv has been hijacked */
4506         }
4507         else if (strEQ(s, "END")) {
4508             if (!PL_endav)
4509                 PL_endav = newAV();
4510             av_unshift(PL_endav, 1);
4511             av_store(PL_endav, 0, (SV*)cv);
4512             GvCV(gv) = 0;               /* cv has been hijacked */
4513         }
4514         else if (strEQ(s, "CHECK")) {
4515             if (!PL_checkav)
4516                 PL_checkav = newAV();
4517             if (PL_main_start && ckWARN(WARN_VOID))
4518                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4519             av_unshift(PL_checkav, 1);
4520             av_store(PL_checkav, 0, (SV*)cv);
4521             GvCV(gv) = 0;               /* cv has been hijacked */
4522         }
4523         else if (strEQ(s, "INIT")) {
4524             if (!PL_initav)
4525                 PL_initav = newAV();
4526             if (PL_main_start && ckWARN(WARN_VOID))
4527                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4528             av_push(PL_initav, (SV*)cv);
4529             GvCV(gv) = 0;               /* cv has been hijacked */
4530         }
4531     }
4532     else
4533         CvANON_on(cv);
4534
4535 done:
4536     return cv;
4537 }
4538
4539 void
4540 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4541 {
4542     register CV *cv;
4543     char *name;
4544     GV *gv;
4545     STRLEN n_a;
4546
4547     if (o)
4548         name = SvPVx(cSVOPo->op_sv, n_a);
4549     else
4550         name = "STDOUT";
4551     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4552 #ifdef GV_UNIQUE_CHECK
4553     if (GvUNIQUE(gv)) {
4554         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4555     }
4556 #endif
4557     GvMULTI_on(gv);
4558     if ((cv = GvFORM(gv))) {
4559         if (ckWARN(WARN_REDEFINE)) {
4560             line_t oldline = CopLINE(PL_curcop);
4561             if (PL_copline != NOLINE)
4562                 CopLINE_set(PL_curcop, PL_copline);
4563             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4564             CopLINE_set(PL_curcop, oldline);
4565         }
4566         SvREFCNT_dec(cv);
4567     }
4568     cv = PL_compcv;
4569     GvFORM(gv) = cv;
4570     CvGV(cv) = gv;
4571     CvFILE_set_from_cop(cv, PL_curcop);
4572
4573
4574     pad_tidy(padtidy_FORMAT);
4575     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4576     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4577     OpREFCNT_set(CvROOT(cv), 1);
4578     CvSTART(cv) = LINKLIST(CvROOT(cv));
4579     CvROOT(cv)->op_next = 0;
4580     CALL_PEEP(CvSTART(cv));
4581     op_free(o);
4582     PL_copline = NOLINE;
4583     LEAVE_SCOPE(floor);
4584 }
4585
4586 OP *
4587 Perl_newANONLIST(pTHX_ OP *o)
4588 {
4589     return newUNOP(OP_REFGEN, 0,
4590         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4591 }
4592
4593 OP *
4594 Perl_newANONHASH(pTHX_ OP *o)
4595 {
4596     return newUNOP(OP_REFGEN, 0,
4597         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4598 }
4599
4600 OP *
4601 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4602 {
4603     return newANONATTRSUB(floor, proto, Nullop, block);
4604 }
4605
4606 OP *
4607 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4608 {
4609     return newUNOP(OP_REFGEN, 0,
4610         newSVOP(OP_ANONCODE, 0,
4611                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4612 }
4613
4614 OP *
4615 Perl_oopsAV(pTHX_ OP *o)
4616 {
4617     switch (o->op_type) {
4618     case OP_PADSV:
4619         o->op_type = OP_PADAV;
4620         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4621         return ref(o, OP_RV2AV);
4622
4623     case OP_RV2SV:
4624         o->op_type = OP_RV2AV;
4625         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4626         ref(o, OP_RV2AV);
4627         break;
4628
4629     default:
4630         if (ckWARN_d(WARN_INTERNAL))
4631             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4632         break;
4633     }
4634     return o;
4635 }
4636
4637 OP *
4638 Perl_oopsHV(pTHX_ OP *o)
4639 {
4640     switch (o->op_type) {
4641     case OP_PADSV:
4642     case OP_PADAV:
4643         o->op_type = OP_PADHV;
4644         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4645         return ref(o, OP_RV2HV);
4646
4647     case OP_RV2SV:
4648     case OP_RV2AV:
4649         o->op_type = OP_RV2HV;
4650         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4651         ref(o, OP_RV2HV);
4652         break;
4653
4654     default:
4655         if (ckWARN_d(WARN_INTERNAL))
4656             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4657         break;
4658     }
4659     return o;
4660 }
4661
4662 OP *
4663 Perl_newAVREF(pTHX_ OP *o)
4664 {
4665     if (o->op_type == OP_PADANY) {
4666         o->op_type = OP_PADAV;
4667         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4668         return o;
4669     }
4670     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4671                 && ckWARN(WARN_DEPRECATED)) {
4672         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4673                 "Using an array as a reference is deprecated");
4674     }
4675     return newUNOP(OP_RV2AV, 0, scalar(o));
4676 }
4677
4678 OP *
4679 Perl_newGVREF(pTHX_ I32 type, OP *o)
4680 {
4681     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4682         return newUNOP(OP_NULL, 0, o);
4683     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4684 }
4685
4686 OP *
4687 Perl_newHVREF(pTHX_ OP *o)
4688 {
4689     if (o->op_type == OP_PADANY) {
4690         o->op_type = OP_PADHV;
4691         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4692         return o;
4693     }
4694     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4695                 && ckWARN(WARN_DEPRECATED)) {
4696         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4697                 "Using a hash as a reference is deprecated");
4698     }
4699     return newUNOP(OP_RV2HV, 0, scalar(o));
4700 }
4701
4702 OP *
4703 Perl_oopsCV(pTHX_ OP *o)
4704 {
4705     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4706     /* STUB */
4707     return o;
4708 }
4709
4710 OP *
4711 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4712 {
4713     return newUNOP(OP_RV2CV, flags, scalar(o));
4714 }
4715
4716 OP *
4717 Perl_newSVREF(pTHX_ OP *o)
4718 {
4719     if (o->op_type == OP_PADANY) {
4720         o->op_type = OP_PADSV;
4721         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4722         return o;
4723     }
4724     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4725         o->op_flags |= OPpDONE_SVREF;
4726         return o;
4727     }
4728     return newUNOP(OP_RV2SV, 0, scalar(o));
4729 }
4730
4731 /* Check routines. */
4732
4733 OP *
4734 Perl_ck_anoncode(pTHX_ OP *o)
4735 {
4736     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4737     cSVOPo->op_sv = Nullsv;
4738     return o;
4739 }
4740
4741 OP *
4742 Perl_ck_bitop(pTHX_ OP *o)
4743 {
4744 #define OP_IS_NUMCOMPARE(op) \
4745         ((op) == OP_LT   || (op) == OP_I_LT || \
4746          (op) == OP_GT   || (op) == OP_I_GT || \
4747          (op) == OP_LE   || (op) == OP_I_LE || \
4748          (op) == OP_GE   || (op) == OP_I_GE || \
4749          (op) == OP_EQ   || (op) == OP_I_EQ || \
4750          (op) == OP_NE   || (op) == OP_I_NE || \
4751          (op) == OP_NCMP || (op) == OP_I_NCMP)
4752     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4753     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4754             && (o->op_type == OP_BIT_OR
4755              || o->op_type == OP_BIT_AND
4756              || o->op_type == OP_BIT_XOR))
4757     {
4758         OP * left = cBINOPo->op_first;
4759         OP * right = left->op_sibling;
4760         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4761                 (left->op_flags & OPf_PARENS) == 0) ||
4762             (OP_IS_NUMCOMPARE(right->op_type) &&
4763                 (right->op_flags & OPf_PARENS) == 0))
4764             if (ckWARN(WARN_PRECEDENCE))
4765                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4766                         "Possible precedence problem on bitwise %c operator",
4767                         o->op_type == OP_BIT_OR ? '|'
4768                             : o->op_type == OP_BIT_AND ? '&' : '^'
4769                         );
4770     }
4771     return o;
4772 }
4773
4774 OP *
4775 Perl_ck_concat(pTHX_ OP *o)
4776 {
4777     OP *kid = cUNOPo->op_first;
4778     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4779             !(kUNOP->op_first->op_flags & OPf_MOD))
4780         o->op_flags |= OPf_STACKED;
4781     return o;
4782 }
4783
4784 OP *
4785 Perl_ck_spair(pTHX_ OP *o)
4786 {
4787     if (o->op_flags & OPf_KIDS) {
4788         OP* newop;
4789         OP* kid;
4790         OPCODE type = o->op_type;
4791         o = modkids(ck_fun(o), type);
4792         kid = cUNOPo->op_first;
4793         newop = kUNOP->op_first->op_sibling;
4794         if (newop &&
4795             (newop->op_sibling ||
4796              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4797              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4798              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4799
4800             return o;
4801         }
4802         op_free(kUNOP->op_first);
4803         kUNOP->op_first = newop;
4804     }
4805     o->op_ppaddr = PL_ppaddr[++o->op_type];
4806     return ck_fun(o);
4807 }
4808
4809 OP *
4810 Perl_ck_delete(pTHX_ OP *o)
4811 {
4812     o = ck_fun(o);
4813     o->op_private = 0;
4814     if (o->op_flags & OPf_KIDS) {
4815         OP *kid = cUNOPo->op_first;
4816         switch (kid->op_type) {
4817         case OP_ASLICE:
4818             o->op_flags |= OPf_SPECIAL;
4819             /* FALL THROUGH */
4820         case OP_HSLICE:
4821             o->op_private |= OPpSLICE;
4822             break;
4823         case OP_AELEM:
4824             o->op_flags |= OPf_SPECIAL;
4825             /* FALL THROUGH */
4826         case OP_HELEM: