This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement "my $_".
[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, 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_seq == (U16)-1)
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 #ifdef USE_ITHREADS
279         if (cPADOPo->op_padix > 0) {
280             /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
281              * may still exist on the pad */
282             pad_swipe(cPADOPo->op_padix, TRUE);
283             cPADOPo->op_padix = 0;
284         }
285 #else
286         SvREFCNT_dec(cSVOPo->op_sv);
287         cSVOPo->op_sv = Nullsv;
288 #endif
289         break;
290     case OP_METHOD_NAMED:
291     case OP_CONST:
292         SvREFCNT_dec(cSVOPo->op_sv);
293         cSVOPo->op_sv = Nullsv;
294 #ifdef USE_ITHREADS
295         /** Bug #15654
296           Even if op_clear does a pad_free for the target of the op,
297           pad_free doesn't actually remove the sv that exists in the bad
298           instead it lives on. This results in that it could be reused as 
299           a target later on when the pad was reallocated.
300         **/
301         if(o->op_targ) {
302           pad_swipe(o->op_targ,1);
303           o->op_targ = 0;
304         }
305 #endif
306         break;
307     case OP_GOTO:
308     case OP_NEXT:
309     case OP_LAST:
310     case OP_REDO:
311         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
312             break;
313         /* FALL THROUGH */
314     case OP_TRANS:
315         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
316             SvREFCNT_dec(cSVOPo->op_sv);
317             cSVOPo->op_sv = Nullsv;
318         }
319         else {
320             Safefree(cPVOPo->op_pv);
321             cPVOPo->op_pv = Nullch;
322         }
323         break;
324     case OP_SUBST:
325         op_free(cPMOPo->op_pmreplroot);
326         goto clear_pmop;
327     case OP_PUSHRE:
328 #ifdef USE_ITHREADS
329         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
330             /* No GvIN_PAD_off here, because other references may still
331              * exist on the pad */
332             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
333         }
334 #else
335         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
336 #endif
337         /* FALL THROUGH */
338     case OP_MATCH:
339     case OP_QR:
340 clear_pmop:
341         {
342             HV *pmstash = PmopSTASH(cPMOPo);
343             if (pmstash && SvREFCNT(pmstash)) {
344                 PMOP *pmop = HvPMROOT(pmstash);
345                 PMOP *lastpmop = NULL;
346                 while (pmop) {
347                     if (cPMOPo == pmop) {
348                         if (lastpmop)
349                             lastpmop->op_pmnext = pmop->op_pmnext;
350                         else
351                             HvPMROOT(pmstash) = pmop->op_pmnext;
352                         break;
353                     }
354                     lastpmop = pmop;
355                     pmop = pmop->op_pmnext;
356                 }
357             }
358             PmopSTASH_free(cPMOPo);
359         }
360         cPMOPo->op_pmreplroot = Nullop;
361         /* we use the "SAFE" version of the PM_ macros here
362          * since sv_clean_all might release some PMOPs
363          * after PL_regex_padav has been cleared
364          * and the clearing of PL_regex_padav needs to
365          * happen before sv_clean_all
366          */
367         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
368         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
369 #ifdef USE_ITHREADS
370         if(PL_regex_pad) {        /* We could be in destruction */
371             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
372             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
373             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
374         }
375 #endif
376
377         break;
378     }
379
380     if (o->op_targ > 0) {
381         pad_free(o->op_targ);
382         o->op_targ = 0;
383     }
384 }
385
386 STATIC void
387 S_cop_free(pTHX_ COP* cop)
388 {
389     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
390     CopFILE_free(cop);
391     CopSTASH_free(cop);
392     if (! specialWARN(cop->cop_warnings))
393         SvREFCNT_dec(cop->cop_warnings);
394     if (! specialCopIO(cop->cop_io)) {
395 #ifdef USE_ITHREADS
396 #if 0
397         STRLEN len;
398         char *s = SvPV(cop->cop_io,len);
399         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
400 #endif
401 #else
402         SvREFCNT_dec(cop->cop_io);
403 #endif
404     }
405 }
406
407 void
408 Perl_op_null(pTHX_ OP *o)
409 {
410     if (o->op_type == OP_NULL)
411         return;
412     op_clear(o);
413     o->op_targ = o->op_type;
414     o->op_type = OP_NULL;
415     o->op_ppaddr = PL_ppaddr[OP_NULL];
416 }
417
418 /* Contextualizers */
419
420 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
421
422 OP *
423 Perl_linklist(pTHX_ OP *o)
424 {
425     register OP *kid;
426
427     if (o->op_next)
428         return o->op_next;
429
430     /* establish postfix order */
431     if (cUNOPo->op_first) {
432         o->op_next = LINKLIST(cUNOPo->op_first);
433         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
434             if (kid->op_sibling)
435                 kid->op_next = LINKLIST(kid->op_sibling);
436             else
437                 kid->op_next = o;
438         }
439     }
440     else
441         o->op_next = o;
442
443     return o->op_next;
444 }
445
446 OP *
447 Perl_scalarkids(pTHX_ OP *o)
448 {
449     OP *kid;
450     if (o && o->op_flags & OPf_KIDS) {
451         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
452             scalar(kid);
453     }
454     return o;
455 }
456
457 STATIC OP *
458 S_scalarboolean(pTHX_ OP *o)
459 {
460     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
461         if (ckWARN(WARN_SYNTAX)) {
462             line_t oldline = CopLINE(PL_curcop);
463
464             if (PL_copline != NOLINE)
465                 CopLINE_set(PL_curcop, PL_copline);
466             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
467             CopLINE_set(PL_curcop, oldline);
468         }
469     }
470     return scalar(o);
471 }
472
473 OP *
474 Perl_scalar(pTHX_ OP *o)
475 {
476     OP *kid;
477
478     /* assumes no premature commitment */
479     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
480          || o->op_type == OP_RETURN)
481     {
482         return o;
483     }
484
485     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
486
487     switch (o->op_type) {
488     case OP_REPEAT:
489         scalar(cBINOPo->op_first);
490         break;
491     case OP_OR:
492     case OP_AND:
493     case OP_COND_EXPR:
494         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
495             scalar(kid);
496         break;
497     case OP_SPLIT:
498         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
499             if (!kPMOP->op_pmreplroot)
500                 deprecate_old("implicit split to @_");
501         }
502         /* FALL THROUGH */
503     case OP_MATCH:
504     case OP_QR:
505     case OP_SUBST:
506     case OP_NULL:
507     default:
508         if (o->op_flags & OPf_KIDS) {
509             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
510                 scalar(kid);
511         }
512         break;
513     case OP_LEAVE:
514     case OP_LEAVETRY:
515         kid = cLISTOPo->op_first;
516         scalar(kid);
517         while ((kid = kid->op_sibling)) {
518             if (kid->op_sibling)
519                 scalarvoid(kid);
520             else
521                 scalar(kid);
522         }
523         WITH_THR(PL_curcop = &PL_compiling);
524         break;
525     case OP_SCOPE:
526     case OP_LINESEQ:
527     case OP_LIST:
528         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
529             if (kid->op_sibling)
530                 scalarvoid(kid);
531             else
532                 scalar(kid);
533         }
534         WITH_THR(PL_curcop = &PL_compiling);
535         break;
536     case OP_SORT:
537         if (ckWARN(WARN_VOID))
538             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
539     }
540     return o;
541 }
542
543 OP *
544 Perl_scalarvoid(pTHX_ OP *o)
545 {
546     OP *kid;
547     char* useless = 0;
548     SV* sv;
549     U8 want;
550
551     if (o->op_type == OP_NEXTSTATE
552         || o->op_type == OP_SETSTATE
553         || o->op_type == OP_DBSTATE
554         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
555                                       || o->op_targ == OP_SETSTATE
556                                       || o->op_targ == OP_DBSTATE)))
557         PL_curcop = (COP*)o;            /* for warning below */
558
559     /* assumes no premature commitment */
560     want = o->op_flags & OPf_WANT;
561     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
562          || o->op_type == OP_RETURN)
563     {
564         return o;
565     }
566
567     if ((o->op_private & OPpTARGET_MY)
568         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
569     {
570         return scalar(o);                       /* As if inside SASSIGN */
571     }
572
573     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
574
575     switch (o->op_type) {
576     default:
577         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
578             break;
579         /* FALL THROUGH */
580     case OP_REPEAT:
581         if (o->op_flags & OPf_STACKED)
582             break;
583         goto func_ops;
584     case OP_SUBSTR:
585         if (o->op_private == 4)
586             break;
587         /* FALL THROUGH */
588     case OP_GVSV:
589     case OP_WANTARRAY:
590     case OP_GV:
591     case OP_PADSV:
592     case OP_PADAV:
593     case OP_PADHV:
594     case OP_PADANY:
595     case OP_AV2ARYLEN:
596     case OP_REF:
597     case OP_REFGEN:
598     case OP_SREFGEN:
599     case OP_DEFINED:
600     case OP_HEX:
601     case OP_OCT:
602     case OP_LENGTH:
603     case OP_VEC:
604     case OP_INDEX:
605     case OP_RINDEX:
606     case OP_SPRINTF:
607     case OP_AELEM:
608     case OP_AELEMFAST:
609     case OP_ASLICE:
610     case OP_HELEM:
611     case OP_HSLICE:
612     case OP_UNPACK:
613     case OP_PACK:
614     case OP_JOIN:
615     case OP_LSLICE:
616     case OP_ANONLIST:
617     case OP_ANONHASH:
618     case OP_SORT:
619     case OP_REVERSE:
620     case OP_RANGE:
621     case OP_FLIP:
622     case OP_FLOP:
623     case OP_CALLER:
624     case OP_FILENO:
625     case OP_EOF:
626     case OP_TELL:
627     case OP_GETSOCKNAME:
628     case OP_GETPEERNAME:
629     case OP_READLINK:
630     case OP_TELLDIR:
631     case OP_GETPPID:
632     case OP_GETPGRP:
633     case OP_GETPRIORITY:
634     case OP_TIME:
635     case OP_TMS:
636     case OP_LOCALTIME:
637     case OP_GMTIME:
638     case OP_GHBYNAME:
639     case OP_GHBYADDR:
640     case OP_GHOSTENT:
641     case OP_GNBYNAME:
642     case OP_GNBYADDR:
643     case OP_GNETENT:
644     case OP_GPBYNAME:
645     case OP_GPBYNUMBER:
646     case OP_GPROTOENT:
647     case OP_GSBYNAME:
648     case OP_GSBYPORT:
649     case OP_GSERVENT:
650     case OP_GPWNAM:
651     case OP_GPWUID:
652     case OP_GGRNAM:
653     case OP_GGRGID:
654     case OP_GETLOGIN:
655     case OP_PROTOTYPE:
656       func_ops:
657         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
658             useless = OP_DESC(o);
659         break;
660
661     case OP_RV2GV:
662     case OP_RV2SV:
663     case OP_RV2AV:
664     case OP_RV2HV:
665         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
666                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
667             useless = "a variable";
668         break;
669
670     case OP_CONST:
671         sv = cSVOPo_sv;
672         if (cSVOPo->op_private & OPpCONST_STRICT)
673             no_bareword_allowed(o);
674         else {
675             if (ckWARN(WARN_VOID)) {
676                 useless = "a constant";
677                 /* the constants 0 and 1 are permitted as they are
678                    conventionally used as dummies in constructs like
679                         1 while some_condition_with_side_effects;  */
680                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
681                     useless = 0;
682                 else if (SvPOK(sv)) {
683                   /* perl4's way of mixing documentation and code
684                      (before the invention of POD) was based on a
685                      trick to mix nroff and perl code. The trick was
686                      built upon these three nroff macros being used in
687                      void context. The pink camel has the details in
688                      the script wrapman near page 319. */
689                     if (strnEQ(SvPVX(sv), "di", 2) ||
690                         strnEQ(SvPVX(sv), "ds", 2) ||
691                         strnEQ(SvPVX(sv), "ig", 2))
692                             useless = 0;
693                 }
694             }
695         }
696         op_null(o);             /* don't execute or even remember it */
697         break;
698
699     case OP_POSTINC:
700         o->op_type = OP_PREINC;         /* pre-increment is faster */
701         o->op_ppaddr = PL_ppaddr[OP_PREINC];
702         break;
703
704     case OP_POSTDEC:
705         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
706         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
707         break;
708
709     case OP_OR:
710     case OP_AND:
711     case OP_DOR:
712     case OP_COND_EXPR:
713         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
714             scalarvoid(kid);
715         break;
716
717     case OP_NULL:
718         if (o->op_flags & OPf_STACKED)
719             break;
720         /* FALL THROUGH */
721     case OP_NEXTSTATE:
722     case OP_DBSTATE:
723     case OP_ENTERTRY:
724     case OP_ENTER:
725         if (!(o->op_flags & OPf_KIDS))
726             break;
727         /* FALL THROUGH */
728     case OP_SCOPE:
729     case OP_LEAVE:
730     case OP_LEAVETRY:
731     case OP_LEAVELOOP:
732     case OP_LINESEQ:
733     case OP_LIST:
734         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
735             scalarvoid(kid);
736         break;
737     case OP_ENTEREVAL:
738         scalarkids(o);
739         break;
740     case OP_REQUIRE:
741         /* all requires must return a boolean value */
742         o->op_flags &= ~OPf_WANT;
743         /* FALL THROUGH */
744     case OP_SCALAR:
745         return scalar(o);
746     case OP_SPLIT:
747         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
748             if (!kPMOP->op_pmreplroot)
749                 deprecate_old("implicit split to @_");
750         }
751         break;
752     }
753     if (useless && ckWARN(WARN_VOID))
754         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
755     return o;
756 }
757
758 OP *
759 Perl_listkids(pTHX_ OP *o)
760 {
761     OP *kid;
762     if (o && o->op_flags & OPf_KIDS) {
763         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
764             list(kid);
765     }
766     return o;
767 }
768
769 OP *
770 Perl_list(pTHX_ OP *o)
771 {
772     OP *kid;
773
774     /* assumes no premature commitment */
775     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
776          || o->op_type == OP_RETURN)
777     {
778         return o;
779     }
780
781     if ((o->op_private & OPpTARGET_MY)
782         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
783     {
784         return o;                               /* As if inside SASSIGN */
785     }
786
787     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
788
789     switch (o->op_type) {
790     case OP_FLOP:
791     case OP_REPEAT:
792         list(cBINOPo->op_first);
793         break;
794     case OP_OR:
795     case OP_AND:
796     case OP_COND_EXPR:
797         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
798             list(kid);
799         break;
800     default:
801     case OP_MATCH:
802     case OP_QR:
803     case OP_SUBST:
804     case OP_NULL:
805         if (!(o->op_flags & OPf_KIDS))
806             break;
807         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
808             list(cBINOPo->op_first);
809             return gen_constant_list(o);
810         }
811     case OP_LIST:
812         listkids(o);
813         break;
814     case OP_LEAVE:
815     case OP_LEAVETRY:
816         kid = cLISTOPo->op_first;
817         list(kid);
818         while ((kid = kid->op_sibling)) {
819             if (kid->op_sibling)
820                 scalarvoid(kid);
821             else
822                 list(kid);
823         }
824         WITH_THR(PL_curcop = &PL_compiling);
825         break;
826     case OP_SCOPE:
827     case OP_LINESEQ:
828         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
829             if (kid->op_sibling)
830                 scalarvoid(kid);
831             else
832                 list(kid);
833         }
834         WITH_THR(PL_curcop = &PL_compiling);
835         break;
836     case OP_REQUIRE:
837         /* all requires must return a boolean value */
838         o->op_flags &= ~OPf_WANT;
839         return scalar(o);
840     }
841     return o;
842 }
843
844 OP *
845 Perl_scalarseq(pTHX_ OP *o)
846 {
847     OP *kid;
848
849     if (o) {
850         if (o->op_type == OP_LINESEQ ||
851              o->op_type == OP_SCOPE ||
852              o->op_type == OP_LEAVE ||
853              o->op_type == OP_LEAVETRY)
854         {
855             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
856                 if (kid->op_sibling) {
857                     scalarvoid(kid);
858                 }
859             }
860             PL_curcop = &PL_compiling;
861         }
862         o->op_flags &= ~OPf_PARENS;
863         if (PL_hints & HINT_BLOCK_SCOPE)
864             o->op_flags |= OPf_PARENS;
865     }
866     else
867         o = newOP(OP_STUB, 0);
868     return o;
869 }
870
871 STATIC OP *
872 S_modkids(pTHX_ OP *o, I32 type)
873 {
874     OP *kid;
875     if (o && o->op_flags & OPf_KIDS) {
876         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
877             mod(kid, type);
878     }
879     return o;
880 }
881
882 /* Propagate lvalue ("modifiable") context to an op and it's children.
883  * 'type' represents the context type, roughly based on the type of op that
884  * would do the modifying, although local() is represented by OP_NULL.
885  * It's responsible for detecting things that can't be modified,  flag
886  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
887  * might have to vivify a reference in $x), and so on.
888  *
889  * For example, "$a+1 = 2" would cause mod() to be called with o being
890  * OP_ADD and type being OP_SASSIGN, and would output an error.
891  */
892
893 OP *
894 Perl_mod(pTHX_ OP *o, I32 type)
895 {
896     OP *kid;
897     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
898     int localize = -1;
899
900     if (!o || PL_error_count)
901         return o;
902
903     if ((o->op_private & OPpTARGET_MY)
904         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
905     {
906         return o;
907     }
908
909     switch (o->op_type) {
910     case OP_UNDEF:
911         localize = 0;
912         PL_modcount++;
913         return o;
914     case OP_CONST:
915         if (!(o->op_private & (OPpCONST_ARYBASE)))
916             goto nomod;
917         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
918             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
919             PL_eval_start = 0;
920         }
921         else if (!type) {
922             SAVEI32(PL_compiling.cop_arybase);
923             PL_compiling.cop_arybase = 0;
924         }
925         else if (type == OP_REFGEN)
926             goto nomod;
927         else
928             Perl_croak(aTHX_ "That use of $[ is unsupported");
929         break;
930     case OP_STUB:
931         if (o->op_flags & OPf_PARENS)
932             break;
933         goto nomod;
934     case OP_ENTERSUB:
935         if ((type == OP_UNDEF || type == OP_REFGEN) &&
936             !(o->op_flags & OPf_STACKED)) {
937             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
938             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
939             assert(cUNOPo->op_first->op_type == OP_NULL);
940             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
941             break;
942         }
943         else if (o->op_private & OPpENTERSUB_NOMOD)
944             return o;
945         else {                          /* lvalue subroutine call */
946             o->op_private |= OPpLVAL_INTRO;
947             PL_modcount = RETURN_UNLIMITED_NUMBER;
948             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
949                 /* Backward compatibility mode: */
950                 o->op_private |= OPpENTERSUB_INARGS;
951                 break;
952             }
953             else {                      /* Compile-time error message: */
954                 OP *kid = cUNOPo->op_first;
955                 CV *cv;
956                 OP *okid;
957
958                 if (kid->op_type == OP_PUSHMARK)
959                     goto skip_kids;
960                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
961                     Perl_croak(aTHX_
962                                "panic: unexpected lvalue entersub "
963                                "args: type/targ %ld:%"UVuf,
964                                (long)kid->op_type, (UV)kid->op_targ);
965                 kid = kLISTOP->op_first;
966               skip_kids:
967                 while (kid->op_sibling)
968                     kid = kid->op_sibling;
969                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
970                     /* Indirect call */
971                     if (kid->op_type == OP_METHOD_NAMED
972                         || kid->op_type == OP_METHOD)
973                     {
974                         UNOP *newop;
975
976                         NewOp(1101, newop, 1, UNOP);
977                         newop->op_type = OP_RV2CV;
978                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
979                         newop->op_first = Nullop;
980                         newop->op_next = (OP*)newop;
981                         kid->op_sibling = (OP*)newop;
982                         newop->op_private |= OPpLVAL_INTRO;
983                         break;
984                     }
985
986                     if (kid->op_type != OP_RV2CV)
987                         Perl_croak(aTHX_
988                                    "panic: unexpected lvalue entersub "
989                                    "entry via type/targ %ld:%"UVuf,
990                                    (long)kid->op_type, (UV)kid->op_targ);
991                     kid->op_private |= OPpLVAL_INTRO;
992                     break;      /* Postpone until runtime */
993                 }
994
995                 okid = kid;
996                 kid = kUNOP->op_first;
997                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
998                     kid = kUNOP->op_first;
999                 if (kid->op_type == OP_NULL)
1000                     Perl_croak(aTHX_
1001                                "Unexpected constant lvalue entersub "
1002                                "entry via type/targ %ld:%"UVuf,
1003                                (long)kid->op_type, (UV)kid->op_targ);
1004                 if (kid->op_type != OP_GV) {
1005                     /* Restore RV2CV to check lvalueness */
1006                   restore_2cv:
1007                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1008                         okid->op_next = kid->op_next;
1009                         kid->op_next = okid;
1010                     }
1011                     else
1012                         okid->op_next = Nullop;
1013                     okid->op_type = OP_RV2CV;
1014                     okid->op_targ = 0;
1015                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1016                     okid->op_private |= OPpLVAL_INTRO;
1017                     break;
1018                 }
1019
1020                 cv = GvCV(kGVOP_gv);
1021                 if (!cv)
1022                     goto restore_2cv;
1023                 if (CvLVALUE(cv))
1024                     break;
1025             }
1026         }
1027         /* FALL THROUGH */
1028     default:
1029       nomod:
1030         /* grep, foreach, subcalls, refgen */
1031         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1032             break;
1033         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1034                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1035                       ? "do block"
1036                       : (o->op_type == OP_ENTERSUB
1037                         ? "non-lvalue subroutine call"
1038                         : OP_DESC(o))),
1039                      type ? PL_op_desc[type] : "local"));
1040         return o;
1041
1042     case OP_PREINC:
1043     case OP_PREDEC:
1044     case OP_POW:
1045     case OP_MULTIPLY:
1046     case OP_DIVIDE:
1047     case OP_MODULO:
1048     case OP_REPEAT:
1049     case OP_ADD:
1050     case OP_SUBTRACT:
1051     case OP_CONCAT:
1052     case OP_LEFT_SHIFT:
1053     case OP_RIGHT_SHIFT:
1054     case OP_BIT_AND:
1055     case OP_BIT_XOR:
1056     case OP_BIT_OR:
1057     case OP_I_MULTIPLY:
1058     case OP_I_DIVIDE:
1059     case OP_I_MODULO:
1060     case OP_I_ADD:
1061     case OP_I_SUBTRACT:
1062         if (!(o->op_flags & OPf_STACKED))
1063             goto nomod;
1064         PL_modcount++;
1065         break;
1066
1067     case OP_COND_EXPR:
1068         localize = 1;
1069         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1070             mod(kid, type);
1071         break;
1072
1073     case OP_RV2AV:
1074     case OP_RV2HV:
1075         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1076            PL_modcount = RETURN_UNLIMITED_NUMBER;
1077             return o;           /* Treat \(@foo) like ordinary list. */
1078         }
1079         /* FALL THROUGH */
1080     case OP_RV2GV:
1081         if (scalar_mod_type(o, type))
1082             goto nomod;
1083         ref(cUNOPo->op_first, o->op_type);
1084         /* FALL THROUGH */
1085     case OP_ASLICE:
1086     case OP_HSLICE:
1087         if (type == OP_LEAVESUBLV)
1088             o->op_private |= OPpMAYBE_LVSUB;
1089         localize = 1;
1090         /* FALL THROUGH */
1091     case OP_AASSIGN:
1092     case OP_NEXTSTATE:
1093     case OP_DBSTATE:
1094        PL_modcount = RETURN_UNLIMITED_NUMBER;
1095         break;
1096     case OP_RV2SV:
1097         ref(cUNOPo->op_first, o->op_type);
1098         localize = 1;
1099         /* FALL THROUGH */
1100     case OP_GV:
1101     case OP_AV2ARYLEN:
1102         PL_hints |= HINT_BLOCK_SCOPE;
1103     case OP_SASSIGN:
1104     case OP_ANDASSIGN:
1105     case OP_ORASSIGN:
1106     case OP_DORASSIGN:
1107         PL_modcount++;
1108         break;
1109
1110     case OP_AELEMFAST:
1111         localize = 1;
1112         PL_modcount++;
1113         break;
1114
1115     case OP_PADAV:
1116     case OP_PADHV:
1117        PL_modcount = RETURN_UNLIMITED_NUMBER;
1118         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1119             return o;           /* Treat \(@foo) like ordinary list. */
1120         if (scalar_mod_type(o, type))
1121             goto nomod;
1122         if (type == OP_LEAVESUBLV)
1123             o->op_private |= OPpMAYBE_LVSUB;
1124         /* FALL THROUGH */
1125     case OP_PADSV:
1126         PL_modcount++;
1127         if (!type) /* local() */
1128             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1129                  PAD_COMPNAME_PV(o->op_targ));
1130         break;
1131
1132     case OP_PUSHMARK:
1133         localize = 0;
1134         break;
1135
1136     case OP_KEYS:
1137         if (type != OP_SASSIGN)
1138             goto nomod;
1139         goto lvalue_func;
1140     case OP_SUBSTR:
1141         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1142             goto nomod;
1143         /* FALL THROUGH */
1144     case OP_POS:
1145     case OP_VEC:
1146         if (type == OP_LEAVESUBLV)
1147             o->op_private |= OPpMAYBE_LVSUB;
1148       lvalue_func:
1149         pad_free(o->op_targ);
1150         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1151         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1152         if (o->op_flags & OPf_KIDS)
1153             mod(cBINOPo->op_first->op_sibling, type);
1154         break;
1155
1156     case OP_AELEM:
1157     case OP_HELEM:
1158         ref(cBINOPo->op_first, o->op_type);
1159         if (type == OP_ENTERSUB &&
1160              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1161             o->op_private |= OPpLVAL_DEFER;
1162         if (type == OP_LEAVESUBLV)
1163             o->op_private |= OPpMAYBE_LVSUB;
1164         localize = 1;
1165         PL_modcount++;
1166         break;
1167
1168     case OP_SCOPE:
1169     case OP_LEAVE:
1170     case OP_ENTER:
1171     case OP_LINESEQ:
1172         localize = 0;
1173         if (o->op_flags & OPf_KIDS)
1174             mod(cLISTOPo->op_last, type);
1175         break;
1176
1177     case OP_NULL:
1178         localize = 0;
1179         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1180             goto nomod;
1181         else if (!(o->op_flags & OPf_KIDS))
1182             break;
1183         if (o->op_targ != OP_LIST) {
1184             mod(cBINOPo->op_first, type);
1185             break;
1186         }
1187         /* FALL THROUGH */
1188     case OP_LIST:
1189         localize = 0;
1190         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1191             mod(kid, type);
1192         break;
1193
1194     case OP_RETURN:
1195         if (type != OP_LEAVESUBLV)
1196             goto nomod;
1197         break; /* mod()ing was handled by ck_return() */
1198     }
1199
1200     /* [20011101.069] File test operators interpret OPf_REF to mean that
1201        their argument is a filehandle; thus \stat(".") should not set
1202        it. AMS 20011102 */
1203     if (type == OP_REFGEN &&
1204         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1205         return o;
1206
1207     if (type != OP_LEAVESUBLV)
1208         o->op_flags |= OPf_MOD;
1209
1210     if (type == OP_AASSIGN || type == OP_SASSIGN)
1211         o->op_flags |= OPf_SPECIAL|OPf_REF;
1212     else if (!type) { /* local() */
1213         switch (localize) {
1214         case 1:
1215             o->op_private |= OPpLVAL_INTRO;
1216             o->op_flags &= ~OPf_SPECIAL;
1217             PL_hints |= HINT_BLOCK_SCOPE;
1218             break;
1219         case 0:
1220             break;
1221         case -1:
1222             if (ckWARN(WARN_SYNTAX)) {
1223                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1224                     "Useless localization of %s", OP_DESC(o));
1225             }
1226         }
1227     }
1228     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1229              && type != OP_LEAVESUBLV)
1230         o->op_flags |= OPf_REF;
1231     return o;
1232 }
1233
1234 STATIC bool
1235 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1236 {
1237     switch (type) {
1238     case OP_SASSIGN:
1239         if (o->op_type == OP_RV2GV)
1240             return FALSE;
1241         /* FALL THROUGH */
1242     case OP_PREINC:
1243     case OP_PREDEC:
1244     case OP_POSTINC:
1245     case OP_POSTDEC:
1246     case OP_I_PREINC:
1247     case OP_I_PREDEC:
1248     case OP_I_POSTINC:
1249     case OP_I_POSTDEC:
1250     case OP_POW:
1251     case OP_MULTIPLY:
1252     case OP_DIVIDE:
1253     case OP_MODULO:
1254     case OP_REPEAT:
1255     case OP_ADD:
1256     case OP_SUBTRACT:
1257     case OP_I_MULTIPLY:
1258     case OP_I_DIVIDE:
1259     case OP_I_MODULO:
1260     case OP_I_ADD:
1261     case OP_I_SUBTRACT:
1262     case OP_LEFT_SHIFT:
1263     case OP_RIGHT_SHIFT:
1264     case OP_BIT_AND:
1265     case OP_BIT_XOR:
1266     case OP_BIT_OR:
1267     case OP_CONCAT:
1268     case OP_SUBST:
1269     case OP_TRANS:
1270     case OP_READ:
1271     case OP_SYSREAD:
1272     case OP_RECV:
1273     case OP_ANDASSIGN:
1274     case OP_ORASSIGN:
1275         return TRUE;
1276     default:
1277         return FALSE;
1278     }
1279 }
1280
1281 STATIC bool
1282 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1283 {
1284     switch (o->op_type) {
1285     case OP_PIPE_OP:
1286     case OP_SOCKPAIR:
1287         if (argnum == 2)
1288             return TRUE;
1289         /* FALL THROUGH */
1290     case OP_SYSOPEN:
1291     case OP_OPEN:
1292     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1293     case OP_SOCKET:
1294     case OP_OPEN_DIR:
1295     case OP_ACCEPT:
1296         if (argnum == 1)
1297             return TRUE;
1298         /* FALL THROUGH */
1299     default:
1300         return FALSE;
1301     }
1302 }
1303
1304 OP *
1305 Perl_refkids(pTHX_ OP *o, I32 type)
1306 {
1307     OP *kid;
1308     if (o && o->op_flags & OPf_KIDS) {
1309         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1310             ref(kid, type);
1311     }
1312     return o;
1313 }
1314
1315 OP *
1316 Perl_ref(pTHX_ OP *o, I32 type)
1317 {
1318     OP *kid;
1319
1320     if (!o || PL_error_count)
1321         return o;
1322
1323     switch (o->op_type) {
1324     case OP_ENTERSUB:
1325         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1326             !(o->op_flags & OPf_STACKED)) {
1327             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1328             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329             assert(cUNOPo->op_first->op_type == OP_NULL);
1330             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1331             o->op_flags |= OPf_SPECIAL;
1332         }
1333         break;
1334
1335     case OP_COND_EXPR:
1336         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1337             ref(kid, type);
1338         break;
1339     case OP_RV2SV:
1340         if (type == OP_DEFINED)
1341             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1342         ref(cUNOPo->op_first, o->op_type);
1343         /* FALL THROUGH */
1344     case OP_PADSV:
1345         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1346             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1347                               : type == OP_RV2HV ? OPpDEREF_HV
1348                               : OPpDEREF_SV);
1349             o->op_flags |= OPf_MOD;
1350         }
1351         break;
1352
1353     case OP_THREADSV:
1354         o->op_flags |= OPf_MOD;         /* XXX ??? */
1355         break;
1356
1357     case OP_RV2AV:
1358     case OP_RV2HV:
1359         o->op_flags |= OPf_REF;
1360         /* FALL THROUGH */
1361     case OP_RV2GV:
1362         if (type == OP_DEFINED)
1363             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1364         ref(cUNOPo->op_first, o->op_type);
1365         break;
1366
1367     case OP_PADAV:
1368     case OP_PADHV:
1369         o->op_flags |= OPf_REF;
1370         break;
1371
1372     case OP_SCALAR:
1373     case OP_NULL:
1374         if (!(o->op_flags & OPf_KIDS))
1375             break;
1376         ref(cBINOPo->op_first, type);
1377         break;
1378     case OP_AELEM:
1379     case OP_HELEM:
1380         ref(cBINOPo->op_first, o->op_type);
1381         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1382             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1383                               : type == OP_RV2HV ? OPpDEREF_HV
1384                               : OPpDEREF_SV);
1385             o->op_flags |= OPf_MOD;
1386         }
1387         break;
1388
1389     case OP_SCOPE:
1390     case OP_LEAVE:
1391     case OP_ENTER:
1392     case OP_LIST:
1393         if (!(o->op_flags & OPf_KIDS))
1394             break;
1395         ref(cLISTOPo->op_last, type);
1396         break;
1397     default:
1398         break;
1399     }
1400     return scalar(o);
1401
1402 }
1403
1404 STATIC OP *
1405 S_dup_attrlist(pTHX_ OP *o)
1406 {
1407     OP *rop = Nullop;
1408
1409     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1410      * where the first kid is OP_PUSHMARK and the remaining ones
1411      * are OP_CONST.  We need to push the OP_CONST values.
1412      */
1413     if (o->op_type == OP_CONST)
1414         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1415     else {
1416         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1417         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1418             if (o->op_type == OP_CONST)
1419                 rop = append_elem(OP_LIST, rop,
1420                                   newSVOP(OP_CONST, o->op_flags,
1421                                           SvREFCNT_inc(cSVOPo->op_sv)));
1422         }
1423     }
1424     return rop;
1425 }
1426
1427 STATIC void
1428 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1429 {
1430     SV *stashsv;
1431
1432     /* fake up C<use attributes $pkg,$rv,@attrs> */
1433     ENTER;              /* need to protect against side-effects of 'use' */
1434     SAVEINT(PL_expect);
1435     if (stash)
1436         stashsv = newSVpv(HvNAME(stash), 0);
1437     else
1438         stashsv = &PL_sv_no;
1439
1440 #define ATTRSMODULE "attributes"
1441 #define ATTRSMODULE_PM "attributes.pm"
1442
1443     if (for_my) {
1444         SV **svp;
1445         /* Don't force the C<use> if we don't need it. */
1446         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1447                        sizeof(ATTRSMODULE_PM)-1, 0);
1448         if (svp && *svp != &PL_sv_undef)
1449             ;           /* already in %INC */
1450         else
1451             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1452                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1453                              Nullsv);
1454     }
1455     else {
1456         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1457                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1458                          Nullsv,
1459                          prepend_elem(OP_LIST,
1460                                       newSVOP(OP_CONST, 0, stashsv),
1461                                       prepend_elem(OP_LIST,
1462                                                    newSVOP(OP_CONST, 0,
1463                                                            newRV(target)),
1464                                                    dup_attrlist(attrs))));
1465     }
1466     LEAVE;
1467 }
1468
1469 STATIC void
1470 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1471 {
1472     OP *pack, *imop, *arg;
1473     SV *meth, *stashsv;
1474
1475     if (!attrs)
1476         return;
1477
1478     assert(target->op_type == OP_PADSV ||
1479            target->op_type == OP_PADHV ||
1480            target->op_type == OP_PADAV);
1481
1482     /* Ensure that attributes.pm is loaded. */
1483     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1484
1485     /* Need package name for method call. */
1486     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1487
1488     /* Build up the real arg-list. */
1489     if (stash)
1490         stashsv = newSVpv(HvNAME(stash), 0);
1491     else
1492         stashsv = &PL_sv_no;
1493     arg = newOP(OP_PADSV, 0);
1494     arg->op_targ = target->op_targ;
1495     arg = prepend_elem(OP_LIST,
1496                        newSVOP(OP_CONST, 0, stashsv),
1497                        prepend_elem(OP_LIST,
1498                                     newUNOP(OP_REFGEN, 0,
1499                                             mod(arg, OP_REFGEN)),
1500                                     dup_attrlist(attrs)));
1501
1502     /* Fake up a method call to import */
1503     meth = newSVpvn("import", 6);
1504     (void)SvUPGRADE(meth, SVt_PVIV);
1505     (void)SvIOK_on(meth);
1506     PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1507     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1508                    append_elem(OP_LIST,
1509                                prepend_elem(OP_LIST, pack, list(arg)),
1510                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1511     imop->op_private |= OPpENTERSUB_NOMOD;
1512
1513     /* Combine the ops. */
1514     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1515 }
1516
1517 /*
1518 =notfor apidoc apply_attrs_string
1519
1520 Attempts to apply a list of attributes specified by the C<attrstr> and
1521 C<len> arguments to the subroutine identified by the C<cv> argument which
1522 is expected to be associated with the package identified by the C<stashpv>
1523 argument (see L<attributes>).  It gets this wrong, though, in that it
1524 does not correctly identify the boundaries of the individual attribute
1525 specifications within C<attrstr>.  This is not really intended for the
1526 public API, but has to be listed here for systems such as AIX which
1527 need an explicit export list for symbols.  (It's called from XS code
1528 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1529 to respect attribute syntax properly would be welcome.
1530
1531 =cut
1532 */
1533
1534 void
1535 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1536                         char *attrstr, STRLEN len)
1537 {
1538     OP *attrs = Nullop;
1539
1540     if (!len) {
1541         len = strlen(attrstr);
1542     }
1543
1544     while (len) {
1545         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1546         if (len) {
1547             char *sstr = attrstr;
1548             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1549             attrs = append_elem(OP_LIST, attrs,
1550                                 newSVOP(OP_CONST, 0,
1551                                         newSVpvn(sstr, attrstr-sstr)));
1552         }
1553     }
1554
1555     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1556                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1557                      Nullsv, prepend_elem(OP_LIST,
1558                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1559                                   prepend_elem(OP_LIST,
1560                                                newSVOP(OP_CONST, 0,
1561                                                        newRV((SV*)cv)),
1562                                                attrs)));
1563 }
1564
1565 STATIC OP *
1566 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1567 {
1568     OP *kid;
1569     I32 type;
1570
1571     if (!o || PL_error_count)
1572         return o;
1573
1574     type = o->op_type;
1575     if (type == OP_LIST) {
1576         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1577             my_kid(kid, attrs, imopsp);
1578     } else if (type == OP_UNDEF) {
1579         return o;
1580     } else if (type == OP_RV2SV ||      /* "our" declaration */
1581                type == OP_RV2AV ||
1582                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1583         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1584             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1585                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1586         } else if (attrs) {
1587             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1588             PL_in_my = FALSE;
1589             PL_in_my_stash = Nullhv;
1590             apply_attrs(GvSTASH(gv),
1591                         (type == OP_RV2SV ? GvSV(gv) :
1592                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1593                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1594                         attrs, FALSE);
1595         }
1596         o->op_private |= OPpOUR_INTRO;
1597         return o;
1598     }
1599     else if (type != OP_PADSV &&
1600              type != OP_PADAV &&
1601              type != OP_PADHV &&
1602              type != OP_PUSHMARK)
1603     {
1604         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1605                           OP_DESC(o),
1606                           PL_in_my == KEY_our ? "our" : "my"));
1607         return o;
1608     }
1609     else if (attrs && type != OP_PUSHMARK) {
1610         HV *stash;
1611
1612         PL_in_my = FALSE;
1613         PL_in_my_stash = Nullhv;
1614
1615         /* check for C<my Dog $spot> when deciding package */
1616         stash = PAD_COMPNAME_TYPE(o->op_targ);
1617         if (!stash)
1618             stash = PL_curstash;
1619         apply_attrs_my(stash, o, attrs, imopsp);
1620     }
1621     o->op_flags |= OPf_MOD;
1622     o->op_private |= OPpLVAL_INTRO;
1623     return o;
1624 }
1625
1626 OP *
1627 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1628 {
1629     OP *rops = Nullop;
1630     int maybe_scalar = 0;
1631
1632 /* [perl #17376]: this appears to be premature, and results in code such as
1633    C< our(%x); > executing in list mode rather than void mode */
1634 #if 0
1635     if (o->op_flags & OPf_PARENS)
1636         list(o);
1637     else
1638         maybe_scalar = 1;
1639 #else
1640     maybe_scalar = 1;
1641 #endif
1642     if (attrs)
1643         SAVEFREEOP(attrs);
1644     o = my_kid(o, attrs, &rops);
1645     if (rops) {
1646         if (maybe_scalar && o->op_type == OP_PADSV) {
1647             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1648             o->op_private |= OPpLVAL_INTRO;
1649         }
1650         else
1651             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1652     }
1653     PL_in_my = FALSE;
1654     PL_in_my_stash = Nullhv;
1655     return o;
1656 }
1657
1658 OP *
1659 Perl_my(pTHX_ OP *o)
1660 {
1661     return my_attrs(o, Nullop);
1662 }
1663
1664 OP *
1665 Perl_sawparens(pTHX_ OP *o)
1666 {
1667     if (o)
1668         o->op_flags |= OPf_PARENS;
1669     return o;
1670 }
1671
1672 OP *
1673 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1674 {
1675     OP *o;
1676     bool ismatchop = 0;
1677
1678     if (ckWARN(WARN_MISC) &&
1679       (left->op_type == OP_RV2AV ||
1680        left->op_type == OP_RV2HV ||
1681        left->op_type == OP_PADAV ||
1682        left->op_type == OP_PADHV)) {
1683       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1684                             right->op_type == OP_TRANS)
1685                            ? right->op_type : OP_MATCH];
1686       const char *sample = ((left->op_type == OP_RV2AV ||
1687                              left->op_type == OP_PADAV)
1688                             ? "@array" : "%hash");
1689       Perl_warner(aTHX_ packWARN(WARN_MISC),
1690              "Applying %s to %s will act on scalar(%s)",
1691              desc, sample, sample);
1692     }
1693
1694     if (right->op_type == OP_CONST &&
1695         cSVOPx(right)->op_private & OPpCONST_BARE &&
1696         cSVOPx(right)->op_private & OPpCONST_STRICT)
1697     {
1698         no_bareword_allowed(right);
1699     }
1700
1701     ismatchop = right->op_type == OP_MATCH ||
1702                 right->op_type == OP_SUBST ||
1703                 right->op_type == OP_TRANS;
1704     if (ismatchop && right->op_private & OPpTARGET_MY) {
1705         right->op_targ = 0;
1706         right->op_private &= ~OPpTARGET_MY;
1707     }
1708     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1709         right->op_flags |= OPf_STACKED;
1710         if (right->op_type != OP_MATCH &&
1711             ! (right->op_type == OP_TRANS &&
1712                right->op_private & OPpTRANS_IDENTICAL))
1713             left = mod(left, right->op_type);
1714         if (right->op_type == OP_TRANS)
1715             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1716         else
1717             o = prepend_elem(right->op_type, scalar(left), right);
1718         if (type == OP_NOT)
1719             return newUNOP(OP_NOT, 0, scalar(o));
1720         return o;
1721     }
1722     else
1723         return bind_match(type, left,
1724                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1725 }
1726
1727 OP *
1728 Perl_invert(pTHX_ OP *o)
1729 {
1730     if (!o)
1731         return o;
1732     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1733     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1734 }
1735
1736 OP *
1737 Perl_scope(pTHX_ OP *o)
1738 {
1739     if (o) {
1740         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1741             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1742             o->op_type = OP_LEAVE;
1743             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1744         }
1745         else if (o->op_type == OP_LINESEQ) {
1746             OP *kid;
1747             o->op_type = OP_SCOPE;
1748             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1749             kid = ((LISTOP*)o)->op_first;
1750             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1751                 op_null(kid);
1752         }
1753         else
1754             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1755     }
1756     return o;
1757 }
1758
1759 void
1760 Perl_save_hints(pTHX)
1761 {
1762     SAVEI32(PL_hints);
1763     SAVESPTR(GvHV(PL_hintgv));
1764     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1765     SAVEFREESV(GvHV(PL_hintgv));
1766 }
1767
1768 int
1769 Perl_block_start(pTHX_ int full)
1770 {
1771     int retval = PL_savestack_ix;
1772     /* If there were syntax errors, don't try to start a block */
1773     if (PL_yynerrs) return retval;
1774
1775     pad_block_start(full);
1776     SAVEHINTS();
1777     PL_hints &= ~HINT_BLOCK_SCOPE;
1778     SAVESPTR(PL_compiling.cop_warnings);
1779     if (! specialWARN(PL_compiling.cop_warnings)) {
1780         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1781         SAVEFREESV(PL_compiling.cop_warnings) ;
1782     }
1783     SAVESPTR(PL_compiling.cop_io);
1784     if (! specialCopIO(PL_compiling.cop_io)) {
1785         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1786         SAVEFREESV(PL_compiling.cop_io) ;
1787     }
1788     return retval;
1789 }
1790
1791 OP*
1792 Perl_block_end(pTHX_ I32 floor, OP *seq)
1793 {
1794     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1795     OP* retval = scalarseq(seq);
1796     /* If there were syntax errors, don't try to close a block */
1797     if (PL_yynerrs) return retval;
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_seq = 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         curop = list(force_list(left));
3128         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3129         o->op_private = (U8)(0 | (flags >> 8));
3130
3131         /* PL_generation sorcery:
3132          * an assignment like ($a,$b) = ($c,$d) is easier than
3133          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3134          * To detect whether there are common vars, the global var
3135          * PL_generation is incremented for each assign op we compile.
3136          * Then, while compiling the assign op, we run through all the
3137          * variables on both sides of the assignment, setting a spare slot
3138          * in each of them to PL_generation. If any of them already have
3139          * that value, we know we've got commonality.  We could use a
3140          * single bit marker, but then we'd have to make 2 passes, first
3141          * to clear the flag, then to test and set it.  To find somewhere
3142          * to store these values, evil chicanery is done with SvCUR().
3143          */
3144
3145         if (!(left->op_private & OPpLVAL_INTRO)) {
3146             OP *lastop = o;
3147             PL_generation++;
3148             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3149                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3150                     if (curop->op_type == OP_GV) {
3151                         GV *gv = cGVOPx_gv(curop);
3152                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3153                             break;
3154                         SvCUR(gv) = PL_generation;
3155                     }
3156                     else if (curop->op_type == OP_PADSV ||
3157                              curop->op_type == OP_PADAV ||
3158                              curop->op_type == OP_PADHV ||
3159                              curop->op_type == OP_PADANY)
3160                     {
3161                         if (PAD_COMPNAME_GEN(curop->op_targ)
3162                                                     == (STRLEN)PL_generation)
3163                             break;
3164                         PAD_COMPNAME_GEN(curop->op_targ)
3165                                                         = PL_generation;
3166
3167                     }
3168                     else if (curop->op_type == OP_RV2CV)
3169                         break;
3170                     else if (curop->op_type == OP_RV2SV ||
3171                              curop->op_type == OP_RV2AV ||
3172                              curop->op_type == OP_RV2HV ||
3173                              curop->op_type == OP_RV2GV) {
3174                         if (lastop->op_type != OP_GV)   /* funny deref? */
3175                             break;
3176                     }
3177                     else if (curop->op_type == OP_PUSHRE) {
3178                         if (((PMOP*)curop)->op_pmreplroot) {
3179 #ifdef USE_ITHREADS
3180                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3181                                         ((PMOP*)curop)->op_pmreplroot));
3182 #else
3183                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3184 #endif
3185                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3186                                 break;
3187                             SvCUR(gv) = PL_generation;
3188                         }
3189                     }
3190                     else
3191                         break;
3192                 }
3193                 lastop = curop;
3194             }
3195             if (curop != o)
3196                 o->op_private |= OPpASSIGN_COMMON;
3197         }
3198         if (right && right->op_type == OP_SPLIT) {
3199             OP* tmpop;
3200             if ((tmpop = ((LISTOP*)right)->op_first) &&
3201                 tmpop->op_type == OP_PUSHRE)
3202             {
3203                 PMOP *pm = (PMOP*)tmpop;
3204                 if (left->op_type == OP_RV2AV &&
3205                     !(left->op_private & OPpLVAL_INTRO) &&
3206                     !(o->op_private & OPpASSIGN_COMMON) )
3207                 {
3208                     tmpop = ((UNOP*)left)->op_first;
3209                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3210 #ifdef USE_ITHREADS
3211                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3212                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3213 #else
3214                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3215                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3216 #endif
3217                         pm->op_pmflags |= PMf_ONCE;
3218                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3219                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3220                         tmpop->op_sibling = Nullop;     /* don't free split */
3221                         right->op_next = tmpop->op_next;  /* fix starting loc */
3222                         op_free(o);                     /* blow off assign */
3223                         right->op_flags &= ~OPf_WANT;
3224                                 /* "I don't know and I don't care." */
3225                         return right;
3226                     }
3227                 }
3228                 else {
3229                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3230                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3231                     {
3232                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3233                         if (SvIVX(sv) == 0)
3234                             sv_setiv(sv, PL_modcount+1);
3235                     }
3236                 }
3237             }
3238         }
3239         return o;
3240     }
3241     if (!right)
3242         right = newOP(OP_UNDEF, 0);
3243     if (right->op_type == OP_READLINE) {
3244         right->op_flags |= OPf_STACKED;
3245         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3246     }
3247     else {
3248         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3249         o = newBINOP(OP_SASSIGN, flags,
3250             scalar(right), mod(scalar(left), OP_SASSIGN) );
3251         if (PL_eval_start)
3252             PL_eval_start = 0;
3253         else {
3254             op_free(o);
3255             return Nullop;
3256         }
3257     }
3258     return o;
3259 }
3260
3261 OP *
3262 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3263 {
3264     U32 seq = intro_my();
3265     register COP *cop;
3266
3267     NewOp(1101, cop, 1, COP);
3268     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3269         cop->op_type = OP_DBSTATE;
3270         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3271     }
3272     else {
3273         cop->op_type = OP_NEXTSTATE;
3274         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3275     }
3276     cop->op_flags = (U8)flags;
3277     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3278 #ifdef NATIVE_HINTS
3279     cop->op_private |= NATIVE_HINTS;
3280 #endif
3281     PL_compiling.op_private = cop->op_private;
3282     cop->op_next = (OP*)cop;
3283
3284     if (label) {
3285         cop->cop_label = label;
3286         PL_hints |= HINT_BLOCK_SCOPE;
3287     }
3288     cop->cop_seq = seq;
3289     cop->cop_arybase = PL_curcop->cop_arybase;
3290     if (specialWARN(PL_curcop->cop_warnings))
3291         cop->cop_warnings = PL_curcop->cop_warnings ;
3292     else
3293         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3294     if (specialCopIO(PL_curcop->cop_io))
3295         cop->cop_io = PL_curcop->cop_io;
3296     else
3297         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3298
3299
3300     if (PL_copline == NOLINE)
3301         CopLINE_set(cop, CopLINE(PL_curcop));
3302     else {
3303         CopLINE_set(cop, PL_copline);
3304         PL_copline = NOLINE;
3305     }
3306 #ifdef USE_ITHREADS
3307     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3308 #else
3309     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3310 #endif
3311     CopSTASH_set(cop, PL_curstash);
3312
3313     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3314         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3315         if (svp && *svp != &PL_sv_undef ) {
3316            (void)SvIOK_on(*svp);
3317             SvIVX(*svp) = PTR2IV(cop);
3318         }
3319     }
3320
3321     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3322 }
3323
3324
3325 OP *
3326 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3327 {
3328     return new_logop(type, flags, &first, &other);
3329 }
3330
3331 STATIC OP *
3332 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3333 {
3334     LOGOP *logop;
3335     OP *o;
3336     OP *first = *firstp;
3337     OP *other = *otherp;
3338
3339     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3340         return newBINOP(type, flags, scalar(first), scalar(other));
3341
3342     scalarboolean(first);
3343     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3344     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3345         if (type == OP_AND || type == OP_OR) {
3346             if (type == OP_AND)
3347                 type = OP_OR;
3348             else
3349                 type = OP_AND;
3350             o = first;
3351             first = *firstp = cUNOPo->op_first;
3352             if (o->op_next)
3353                 first->op_next = o->op_next;
3354             cUNOPo->op_first = Nullop;
3355             op_free(o);
3356         }
3357     }
3358     if (first->op_type == OP_CONST) {
3359         if (first->op_private & OPpCONST_STRICT)
3360             no_bareword_allowed(first);
3361         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3362                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3363         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3364             op_free(first);
3365             *firstp = Nullop;
3366             return other;
3367         }
3368         else {
3369             op_free(other);
3370             *otherp = Nullop;
3371             return first;
3372         }
3373     }
3374     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3375              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3376     {
3377         OP *k1 = ((UNOP*)first)->op_first;
3378         OP *k2 = k1->op_sibling;
3379         OPCODE warnop = 0;
3380         switch (first->op_type)
3381         {
3382         case OP_NULL:
3383             if (k2 && k2->op_type == OP_READLINE
3384                   && (k2->op_flags & OPf_STACKED)
3385                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3386             {
3387                 warnop = k2->op_type;
3388             }
3389             break;
3390
3391         case OP_SASSIGN:
3392             if (k1->op_type == OP_READDIR
3393                   || k1->op_type == OP_GLOB
3394                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3395                   || k1->op_type == OP_EACH)
3396             {
3397                 warnop = ((k1->op_type == OP_NULL)
3398                           ? (OPCODE)k1->op_targ : k1->op_type);
3399             }
3400             break;
3401         }
3402         if (warnop) {
3403             line_t oldline = CopLINE(PL_curcop);
3404             CopLINE_set(PL_curcop, PL_copline);
3405             Perl_warner(aTHX_ packWARN(WARN_MISC),
3406                  "Value of %s%s can be \"0\"; test with defined()",
3407                  PL_op_desc[warnop],
3408                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3409                   ? " construct" : "() operator"));
3410             CopLINE_set(PL_curcop, oldline);
3411         }
3412     }
3413
3414     if (!other)
3415         return first;
3416
3417     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3418         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3419
3420     NewOp(1101, logop, 1, LOGOP);
3421
3422     logop->op_type = (OPCODE)type;
3423     logop->op_ppaddr = PL_ppaddr[type];
3424     logop->op_first = first;
3425     logop->op_flags = flags | OPf_KIDS;
3426     logop->op_other = LINKLIST(other);
3427     logop->op_private = (U8)(1 | (flags >> 8));
3428
3429     /* establish postfix order */
3430     logop->op_next = LINKLIST(first);
3431     first->op_next = (OP*)logop;
3432     first->op_sibling = other;
3433
3434     CHECKOP(type,logop);
3435
3436     o = newUNOP(OP_NULL, 0, (OP*)logop);
3437     other->op_next = o;
3438
3439     return o;
3440 }
3441
3442 OP *
3443 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3444 {
3445     LOGOP *logop;
3446     OP *start;
3447     OP *o;
3448
3449     if (!falseop)
3450         return newLOGOP(OP_AND, 0, first, trueop);
3451     if (!trueop)
3452         return newLOGOP(OP_OR, 0, first, falseop);
3453
3454     scalarboolean(first);
3455     if (first->op_type == OP_CONST) {
3456         if (first->op_private & OPpCONST_BARE &&
3457            first->op_private & OPpCONST_STRICT) {
3458            no_bareword_allowed(first);
3459        }
3460         if (SvTRUE(((SVOP*)first)->op_sv)) {
3461             op_free(first);
3462             op_free(falseop);
3463             return trueop;
3464         }
3465         else {
3466             op_free(first);
3467             op_free(trueop);
3468             return falseop;
3469         }
3470     }
3471     NewOp(1101, logop, 1, LOGOP);
3472     logop->op_type = OP_COND_EXPR;
3473     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3474     logop->op_first = first;
3475     logop->op_flags = flags | OPf_KIDS;
3476     logop->op_private = (U8)(1 | (flags >> 8));
3477     logop->op_other = LINKLIST(trueop);
3478     logop->op_next = LINKLIST(falseop);
3479
3480     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3481             logop);
3482
3483     /* establish postfix order */
3484     start = LINKLIST(first);
3485     first->op_next = (OP*)logop;
3486
3487     first->op_sibling = trueop;
3488     trueop->op_sibling = falseop;
3489     o = newUNOP(OP_NULL, 0, (OP*)logop);
3490
3491     trueop->op_next = falseop->op_next = o;
3492
3493     o->op_next = start;
3494     return o;
3495 }
3496
3497 OP *
3498 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3499 {
3500     LOGOP *range;
3501     OP *flip;
3502     OP *flop;
3503     OP *leftstart;
3504     OP *o;
3505
3506     NewOp(1101, range, 1, LOGOP);
3507
3508     range->op_type = OP_RANGE;
3509     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3510     range->op_first = left;
3511     range->op_flags = OPf_KIDS;
3512     leftstart = LINKLIST(left);
3513     range->op_other = LINKLIST(right);
3514     range->op_private = (U8)(1 | (flags >> 8));
3515
3516     left->op_sibling = right;
3517
3518     range->op_next = (OP*)range;
3519     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3520     flop = newUNOP(OP_FLOP, 0, flip);
3521     o = newUNOP(OP_NULL, 0, flop);
3522     linklist(flop);
3523     range->op_next = leftstart;
3524
3525     left->op_next = flip;
3526     right->op_next = flop;
3527
3528     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3529     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3530     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3531     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3532
3533     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3534     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3535
3536     flip->op_next = o;
3537     if (!flip->op_private || !flop->op_private)
3538         linklist(o);            /* blow off optimizer unless constant */
3539
3540     return o;
3541 }
3542
3543 OP *
3544 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3545 {
3546     OP* listop;
3547     OP* o;
3548     int once = block && block->op_flags & OPf_SPECIAL &&
3549       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3550
3551     if (expr) {
3552         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3553             return block;       /* do {} while 0 does once */
3554         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3555             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3556             expr = newUNOP(OP_DEFINED, 0,
3557                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3558         } else if (expr->op_flags & OPf_KIDS) {
3559             OP *k1 = ((UNOP*)expr)->op_first;
3560             OP *k2 = (k1) ? k1->op_sibling : NULL;
3561             switch (expr->op_type) {
3562               case OP_NULL:
3563                 if (k2 && k2->op_type == OP_READLINE
3564                       && (k2->op_flags & OPf_STACKED)
3565                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3566                     expr = newUNOP(OP_DEFINED, 0, expr);
3567                 break;
3568
3569               case OP_SASSIGN:
3570                 if (k1->op_type == OP_READDIR
3571                       || k1->op_type == OP_GLOB
3572                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3573                       || k1->op_type == OP_EACH)
3574                     expr = newUNOP(OP_DEFINED, 0, expr);
3575                 break;
3576             }
3577         }
3578     }
3579
3580     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3581     o = new_logop(OP_AND, 0, &expr, &listop);
3582
3583     if (listop)
3584         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3585
3586     if (once && o != listop)
3587         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3588
3589     if (o == listop)
3590         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3591
3592     o->op_flags |= flags;
3593     o = scope(o);
3594     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3595     return o;
3596 }
3597
3598 OP *
3599 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3600 {
3601     OP *redo;
3602     OP *next = 0;
3603     OP *listop;
3604     OP *o;
3605     U8 loopflags = 0;
3606
3607     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3608                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3609         expr = newUNOP(OP_DEFINED, 0,
3610             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3611     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3612         OP *k1 = ((UNOP*)expr)->op_first;
3613         OP *k2 = (k1) ? k1->op_sibling : NULL;
3614         switch (expr->op_type) {
3615           case OP_NULL:
3616             if (k2 && k2->op_type == OP_READLINE
3617                   && (k2->op_flags & OPf_STACKED)
3618                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3619                 expr = newUNOP(OP_DEFINED, 0, expr);
3620             break;
3621
3622           case OP_SASSIGN:
3623             if (k1->op_type == OP_READDIR
3624                   || k1->op_type == OP_GLOB
3625                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3626                   || k1->op_type == OP_EACH)
3627                 expr = newUNOP(OP_DEFINED, 0, expr);
3628             break;
3629         }
3630     }
3631
3632     if (!block)
3633         block = newOP(OP_NULL, 0);
3634     else if (cont) {
3635         block = scope(block);
3636     }
3637
3638     if (cont) {
3639         next = LINKLIST(cont);
3640     }
3641     if (expr) {
3642         OP *unstack = newOP(OP_UNSTACK, 0);
3643         if (!next)
3644             next = unstack;
3645         cont = append_elem(OP_LINESEQ, cont, unstack);
3646     }
3647
3648     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3649     redo = LINKLIST(listop);
3650
3651     if (expr) {
3652         PL_copline = (line_t)whileline;
3653         scalar(listop);
3654         o = new_logop(OP_AND, 0, &expr, &listop);
3655         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3656             op_free(expr);              /* oops, it's a while (0) */
3657             op_free((OP*)loop);
3658             return Nullop;              /* listop already freed by new_logop */
3659         }
3660         if (listop)
3661             ((LISTOP*)listop)->op_last->op_next =
3662                 (o == listop ? redo : LINKLIST(o));
3663     }
3664     else
3665         o = listop;
3666
3667     if (!loop) {
3668         NewOp(1101,loop,1,LOOP);
3669         loop->op_type = OP_ENTERLOOP;
3670         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3671         loop->op_private = 0;
3672         loop->op_next = (OP*)loop;
3673     }
3674
3675     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3676
3677     loop->op_redoop = redo;
3678     loop->op_lastop = o;
3679     o->op_private |= loopflags;
3680
3681     if (next)
3682         loop->op_nextop = next;
3683     else
3684         loop->op_nextop = o;
3685
3686     o->op_flags |= flags;
3687     o->op_private |= (flags >> 8);
3688     return o;
3689 }
3690
3691 OP *
3692 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3693 {
3694     LOOP *loop;
3695     OP *wop;
3696     PADOFFSET padoff = 0;
3697     I32 iterflags = 0;
3698     I32 iterpflags = 0;
3699
3700     if (sv) {
3701         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3702             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3703             sv->op_type = OP_RV2GV;
3704             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3705         }
3706         else if (sv->op_type == OP_PADSV) { /* private variable */
3707             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3708             padoff = sv->op_targ;
3709             sv->op_targ = 0;
3710             op_free(sv);
3711             sv = Nullop;
3712         }
3713         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3714             padoff = sv->op_targ;
3715             sv->op_targ = 0;
3716             iterflags |= OPf_SPECIAL;
3717             op_free(sv);
3718             sv = Nullop;
3719         }
3720         else
3721             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3722     }
3723     else {
3724         sv = newGVOP(OP_GV, 0, PL_defgv);
3725     }
3726     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3727         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3728         iterflags |= OPf_STACKED;
3729     }
3730     else if (expr->op_type == OP_NULL &&
3731              (expr->op_flags & OPf_KIDS) &&
3732              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3733     {
3734         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3735          * set the STACKED flag to indicate that these values are to be
3736          * treated as min/max values by 'pp_iterinit'.
3737          */
3738         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3739         LOGOP* range = (LOGOP*) flip->op_first;
3740         OP* left  = range->op_first;
3741         OP* right = left->op_sibling;
3742         LISTOP* listop;
3743
3744         range->op_flags &= ~OPf_KIDS;
3745         range->op_first = Nullop;
3746
3747         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3748         listop->op_first->op_next = range->op_next;
3749         left->op_next = range->op_other;
3750         right->op_next = (OP*)listop;
3751         listop->op_next = listop->op_first;
3752
3753         op_free(expr);
3754         expr = (OP*)(listop);
3755         op_null(expr);
3756         iterflags |= OPf_STACKED;
3757     }
3758     else {
3759         expr = mod(force_list(expr), OP_GREPSTART);
3760     }
3761
3762
3763     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3764                                append_elem(OP_LIST, expr, scalar(sv))));
3765     assert(!loop->op_next);
3766     /* for my  $x () sets OPpLVAL_INTRO;
3767      * for our $x () sets OPpOUR_INTRO */
3768     loop->op_private = (U8)iterpflags;
3769 #ifdef PL_OP_SLAB_ALLOC
3770     {
3771         LOOP *tmp;
3772         NewOp(1234,tmp,1,LOOP);
3773         Copy(loop,tmp,1,LOOP);
3774         FreeOp(loop);
3775         loop = tmp;
3776     }
3777 #else
3778     Renew(loop, 1, LOOP);
3779 #endif
3780     loop->op_targ = padoff;
3781     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3782     PL_copline = forline;
3783     return newSTATEOP(0, label, wop);
3784 }
3785
3786 OP*
3787 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3788 {
3789     OP *o;
3790     STRLEN n_a;
3791
3792     if (type != OP_GOTO || label->op_type == OP_CONST) {
3793         /* "last()" means "last" */
3794         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3795             o = newOP(type, OPf_SPECIAL);
3796         else {
3797             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3798                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3799                                         : ""));
3800         }
3801         op_free(label);
3802     }
3803     else {
3804         /* Check whether it's going to be a goto &function */
3805         if (label->op_type == OP_ENTERSUB
3806                 && !(label->op_flags & OPf_STACKED))
3807             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3808         o = newUNOP(type, OPf_STACKED, label);
3809     }
3810     PL_hints |= HINT_BLOCK_SCOPE;
3811     return o;
3812 }
3813
3814 /*
3815 =for apidoc cv_undef
3816
3817 Clear out all the active components of a CV. This can happen either
3818 by an explicit C<undef &foo>, or by the reference count going to zero.
3819 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3820 children can still follow the full lexical scope chain.
3821
3822 =cut
3823 */
3824
3825 void
3826 Perl_cv_undef(pTHX_ CV *cv)
3827 {
3828 #ifdef USE_ITHREADS
3829     if (CvFILE(cv) && !CvXSUB(cv)) {
3830         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3831         Safefree(CvFILE(cv));
3832     }
3833     CvFILE(cv) = 0;
3834 #endif
3835
3836     if (!CvXSUB(cv) && CvROOT(cv)) {
3837         if (CvDEPTH(cv))
3838             Perl_croak(aTHX_ "Can't undef active subroutine");
3839         ENTER;
3840
3841         PAD_SAVE_SETNULLPAD();
3842
3843         op_free(CvROOT(cv));
3844         CvROOT(cv) = Nullop;
3845         LEAVE;
3846     }
3847     SvPOK_off((SV*)cv);         /* forget prototype */
3848     CvGV(cv) = Nullgv;
3849
3850     pad_undef(cv);
3851
3852     /* remove CvOUTSIDE unless this is an undef rather than a free */
3853     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3854         if (!CvWEAKOUTSIDE(cv))
3855             SvREFCNT_dec(CvOUTSIDE(cv));
3856         CvOUTSIDE(cv) = Nullcv;
3857     }
3858     if (CvCONST(cv)) {
3859         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3860         CvCONST_off(cv);
3861     }
3862     if (CvXSUB(cv)) {
3863         CvXSUB(cv) = 0;
3864     }
3865     /* delete all flags except WEAKOUTSIDE */
3866     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3867 }
3868
3869 void
3870 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3871 {
3872     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3873         SV* msg = sv_newmortal();
3874         SV* name = Nullsv;
3875
3876         if (gv)
3877             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3878         sv_setpv(msg, "Prototype mismatch:");
3879         if (name)
3880             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3881         if (SvPOK(cv))
3882             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3883         sv_catpv(msg, " vs ");
3884         if (p)
3885             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3886         else
3887             sv_catpv(msg, "none");
3888         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3889     }
3890 }
3891
3892 static void const_sv_xsub(pTHX_ CV* cv);
3893
3894 /*
3895
3896 =head1 Optree Manipulation Functions
3897
3898 =for apidoc cv_const_sv
3899
3900 If C<cv> is a constant sub eligible for inlining. returns the constant
3901 value returned by the sub.  Otherwise, returns NULL.
3902
3903 Constant subs can be created with C<newCONSTSUB> or as described in
3904 L<perlsub/"Constant Functions">.
3905
3906 =cut
3907 */
3908 SV *
3909 Perl_cv_const_sv(pTHX_ CV *cv)
3910 {
3911     if (!cv || !CvCONST(cv))
3912         return Nullsv;
3913     return (SV*)CvXSUBANY(cv).any_ptr;
3914 }
3915
3916 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3917  * Can be called in 3 ways:
3918  *
3919  * !cv
3920  *      look for a single OP_CONST with attached value: return the value
3921  *
3922  * cv && CvCLONE(cv) && !CvCONST(cv)
3923  *
3924  *      examine the clone prototype, and if contains only a single
3925  *      OP_CONST referencing a pad const, or a single PADSV referencing
3926  *      an outer lexical, return a non-zero value to indicate the CV is
3927  *      a candidate for "constizing" at clone time
3928  *
3929  * cv && CvCONST(cv)
3930  *
3931  *      We have just cloned an anon prototype that was marked as a const
3932  *      candidiate. Try to grab the current value, and in the case of
3933  *      PADSV, ignore it if it has multiple references. Return the value.
3934  */
3935
3936 SV *
3937 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3938 {
3939     SV *sv = Nullsv;
3940
3941     if (!o)
3942         return Nullsv;
3943
3944     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3945         o = cLISTOPo->op_first->op_sibling;
3946
3947     for (; o; o = o->op_next) {
3948         OPCODE type = o->op_type;
3949
3950         if (sv && o->op_next == o)
3951             return sv;
3952         if (o->op_next != o) {
3953             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3954                 continue;
3955             if (type == OP_DBSTATE)
3956                 continue;
3957         }
3958         if (type == OP_LEAVESUB || type == OP_RETURN)
3959             break;
3960         if (sv)
3961             return Nullsv;
3962         if (type == OP_CONST && cSVOPo->op_sv)
3963             sv = cSVOPo->op_sv;
3964         else if (cv && type == OP_CONST) {
3965             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3966             if (!sv)
3967                 return Nullsv;
3968         }
3969         else if (cv && type == OP_PADSV) {
3970             if (CvCONST(cv)) { /* newly cloned anon */
3971                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3972                 /* the candidate should have 1 ref from this pad and 1 ref
3973                  * from the parent */
3974                 if (!sv || SvREFCNT(sv) != 2)
3975                     return Nullsv;
3976                 sv = newSVsv(sv);
3977                 SvREADONLY_on(sv);
3978                 return sv;
3979             }
3980             else {
3981                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3982                     sv = &PL_sv_undef; /* an arbitrary non-null value */
3983             }
3984         }
3985         else {
3986             return Nullsv;
3987         }
3988     }
3989     return sv;
3990 }
3991
3992 void
3993 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3994 {
3995     if (o)
3996         SAVEFREEOP(o);
3997     if (proto)
3998         SAVEFREEOP(proto);
3999     if (attrs)
4000         SAVEFREEOP(attrs);
4001     if (block)
4002         SAVEFREEOP(block);
4003     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4004 }
4005
4006 CV *
4007 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4008 {
4009     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4010 }
4011
4012 CV *
4013 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4014 {
4015     STRLEN n_a;
4016     char *name;
4017     char *aname;
4018     GV *gv;
4019     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4020     register CV *cv=0;
4021     SV *const_sv;
4022
4023     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4024     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4025         SV *sv = sv_newmortal();
4026         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4027                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4028                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4029         aname = SvPVX(sv);
4030     }
4031     else
4032         aname = Nullch;
4033     gv = gv_fetchpv(name ? name : (aname ? aname : 
4034                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4035                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4036                     SVt_PVCV);
4037
4038     if (o)
4039         SAVEFREEOP(o);
4040     if (proto)
4041         SAVEFREEOP(proto);
4042     if (attrs)
4043         SAVEFREEOP(attrs);
4044
4045     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4046                                            maximum a prototype before. */
4047         if (SvTYPE(gv) > SVt_NULL) {
4048             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4049                 && ckWARN_d(WARN_PROTOTYPE))
4050             {
4051                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4052             }
4053             cv_ckproto((CV*)gv, NULL, ps);
4054         }
4055         if (ps)
4056             sv_setpv((SV*)gv, ps);
4057         else
4058             sv_setiv((SV*)gv, -1);
4059         SvREFCNT_dec(PL_compcv);
4060         cv = PL_compcv = NULL;
4061         PL_sub_generation++;
4062         goto done;
4063     }
4064
4065     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4066
4067 #ifdef GV_UNIQUE_CHECK
4068     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4069         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4070     }
4071 #endif
4072
4073     if (!block || !ps || *ps || attrs)
4074         const_sv = Nullsv;
4075     else
4076         const_sv = op_const_sv(block, Nullcv);
4077
4078     if (cv) {
4079         bool exists = CvROOT(cv) || CvXSUB(cv);
4080
4081 #ifdef GV_UNIQUE_CHECK
4082         if (exists && GvUNIQUE(gv)) {
4083             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4084         }
4085 #endif
4086
4087         /* if the subroutine doesn't exist and wasn't pre-declared
4088          * with a prototype, assume it will be AUTOLOADed,
4089          * skipping the prototype check
4090          */
4091         if (exists || SvPOK(cv))
4092             cv_ckproto(cv, gv, ps);
4093         /* already defined (or promised)? */
4094         if (exists || GvASSUMECV(gv)) {
4095             if (!block && !attrs) {
4096                 if (CvFLAGS(PL_compcv)) {
4097                     /* might have had built-in attrs applied */
4098                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4099                 }
4100                 /* just a "sub foo;" when &foo is already defined */
4101                 SAVEFREESV(PL_compcv);
4102                 goto done;
4103             }
4104             /* ahem, death to those who redefine active sort subs */
4105             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4106                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4107             if (block) {
4108                 if (ckWARN(WARN_REDEFINE)
4109                     || (CvCONST(cv)
4110                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4111                 {
4112                     line_t oldline = CopLINE(PL_curcop);
4113                     if (PL_copline != NOLINE)
4114                         CopLINE_set(PL_curcop, PL_copline);
4115                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4116                         CvCONST(cv) ? "Constant subroutine %s redefined"
4117                                     : "Subroutine %s redefined", name);
4118                     CopLINE_set(PL_curcop, oldline);
4119                 }
4120                 SvREFCNT_dec(cv);
4121                 cv = Nullcv;
4122             }
4123         }
4124     }
4125     if (const_sv) {
4126         SvREFCNT_inc(const_sv);
4127         if (cv) {
4128             assert(!CvROOT(cv) && !CvCONST(cv));
4129             sv_setpv((SV*)cv, "");  /* prototype is "" */
4130             CvXSUBANY(cv).any_ptr = const_sv;
4131             CvXSUB(cv) = const_sv_xsub;
4132             CvCONST_on(cv);
4133         }
4134         else {
4135             GvCV(gv) = Nullcv;
4136             cv = newCONSTSUB(NULL, name, const_sv);
4137         }
4138         op_free(block);
4139         SvREFCNT_dec(PL_compcv);
4140         PL_compcv = NULL;
4141         PL_sub_generation++;
4142         goto done;
4143     }
4144     if (attrs) {
4145         HV *stash;
4146         SV *rcv;
4147
4148         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4149          * before we clobber PL_compcv.
4150          */
4151         if (cv && !block) {
4152             rcv = (SV*)cv;
4153             /* Might have had built-in attributes applied -- propagate them. */
4154             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4155             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4156                 stash = GvSTASH(CvGV(cv));
4157             else if (CvSTASH(cv))
4158                 stash = CvSTASH(cv);
4159             else
4160                 stash = PL_curstash;
4161         }
4162         else {
4163             /* possibly about to re-define existing subr -- ignore old cv */
4164             rcv = (SV*)PL_compcv;
4165             if (name && GvSTASH(gv))
4166                 stash = GvSTASH(gv);
4167             else
4168                 stash = PL_curstash;
4169         }
4170         apply_attrs(stash, rcv, attrs, FALSE);
4171     }
4172     if (cv) {                           /* must reuse cv if autoloaded */
4173         if (!block) {
4174             /* got here with just attrs -- work done, so bug out */
4175             SAVEFREESV(PL_compcv);
4176             goto done;
4177         }
4178         /* transfer PL_compcv to cv */
4179         cv_undef(cv);
4180         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4181         if (!CvWEAKOUTSIDE(cv))
4182             SvREFCNT_dec(CvOUTSIDE(cv));
4183         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4184         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4185         CvOUTSIDE(PL_compcv) = 0;
4186         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4187         CvPADLIST(PL_compcv) = 0;
4188         /* inner references to PL_compcv must be fixed up ... */
4189         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4190         /* ... before we throw it away */
4191         SvREFCNT_dec(PL_compcv);
4192         PL_compcv = cv;
4193         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4194           ++PL_sub_generation;
4195     }
4196     else {
4197         cv = PL_compcv;
4198         if (name) {
4199             GvCV(gv) = cv;
4200             GvCVGEN(gv) = 0;
4201             PL_sub_generation++;
4202         }
4203     }
4204     CvGV(cv) = gv;
4205     CvFILE_set_from_cop(cv, PL_curcop);
4206     CvSTASH(cv) = PL_curstash;
4207
4208     if (ps)
4209         sv_setpv((SV*)cv, ps);
4210
4211     if (PL_error_count) {
4212         op_free(block);
4213         block = Nullop;
4214         if (name) {
4215             char *s = strrchr(name, ':');
4216             s = s ? s+1 : name;
4217             if (strEQ(s, "BEGIN")) {
4218                 char *not_safe =
4219                     "BEGIN not safe after errors--compilation aborted";
4220                 if (PL_in_eval & EVAL_KEEPERR)
4221                     Perl_croak(aTHX_ not_safe);
4222                 else {
4223                     /* force display of errors found but not reported */
4224                     sv_catpv(ERRSV, not_safe);
4225                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4226                 }
4227             }
4228         }
4229     }
4230     if (!block)
4231         goto done;
4232
4233     if (CvLVALUE(cv)) {
4234         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4235                              mod(scalarseq(block), OP_LEAVESUBLV));
4236     }
4237     else {
4238         /* This makes sub {}; work as expected.  */
4239         if (block->op_type == OP_STUB) {
4240             op_free(block);
4241             block = newSTATEOP(0, Nullch, 0);
4242         }
4243         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4244     }
4245     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4246     OpREFCNT_set(CvROOT(cv), 1);
4247     CvSTART(cv) = LINKLIST(CvROOT(cv));
4248     CvROOT(cv)->op_next = 0;
4249     CALL_PEEP(CvSTART(cv));
4250
4251     /* now that optimizer has done its work, adjust pad values */
4252
4253     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4254
4255     if (CvCLONE(cv)) {
4256         assert(!CvCONST(cv));
4257         if (ps && !*ps && op_const_sv(block, cv))
4258             CvCONST_on(cv);
4259     }
4260
4261     if (name || aname) {
4262         char *s;
4263         char *tname = (name ? name : aname);
4264
4265         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4266             SV *sv = NEWSV(0,0);
4267             SV *tmpstr = sv_newmortal();
4268             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4269             CV *pcv;
4270             HV *hv;
4271
4272             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4273                            CopFILE(PL_curcop),
4274                            (long)PL_subline, (long)CopLINE(PL_curcop));
4275             gv_efullname3(tmpstr, gv, Nullch);
4276             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4277             hv = GvHVn(db_postponed);
4278             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4279                 && (pcv = GvCV(db_postponed)))
4280             {
4281                 dSP;
4282                 PUSHMARK(SP);
4283                 XPUSHs(tmpstr);
4284                 PUTBACK;
4285                 call_sv((SV*)pcv, G_DISCARD);
4286             }
4287         }
4288
4289         if ((s = strrchr(tname,':')))
4290             s++;
4291         else
4292             s = tname;
4293
4294         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4295             goto done;
4296
4297         if (strEQ(s, "BEGIN") && !PL_error_count) {
4298             I32 oldscope = PL_scopestack_ix;
4299             ENTER;
4300             SAVECOPFILE(&PL_compiling);
4301             SAVECOPLINE(&PL_compiling);
4302
4303             if (!PL_beginav)
4304                 PL_beginav = newAV();
4305             DEBUG_x( dump_sub(gv) );
4306             av_push(PL_beginav, (SV*)cv);
4307             GvCV(gv) = 0;               /* cv has been hijacked */
4308             call_list(oldscope, PL_beginav);
4309
4310             PL_curcop = &PL_compiling;
4311             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4312             LEAVE;
4313         }
4314         else if (strEQ(s, "END") && !PL_error_count) {
4315             if (!PL_endav)
4316                 PL_endav = newAV();
4317             DEBUG_x( dump_sub(gv) );
4318             av_unshift(PL_endav, 1);
4319             av_store(PL_endav, 0, (SV*)cv);
4320             GvCV(gv) = 0;               /* cv has been hijacked */
4321         }
4322         else if (strEQ(s, "CHECK") && !PL_error_count) {
4323             if (!PL_checkav)
4324                 PL_checkav = newAV();
4325             DEBUG_x( dump_sub(gv) );
4326             if (PL_main_start && ckWARN(WARN_VOID))
4327                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4328             av_unshift(PL_checkav, 1);
4329             av_store(PL_checkav, 0, (SV*)cv);
4330             GvCV(gv) = 0;               /* cv has been hijacked */
4331         }
4332         else if (strEQ(s, "INIT") && !PL_error_count) {
4333             if (!PL_initav)
4334                 PL_initav = newAV();
4335             DEBUG_x( dump_sub(gv) );
4336             if (PL_main_start && ckWARN(WARN_VOID))
4337                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4338             av_push(PL_initav, (SV*)cv);
4339             GvCV(gv) = 0;               /* cv has been hijacked */
4340         }
4341     }
4342
4343   done:
4344     PL_copline = NOLINE;
4345     LEAVE_SCOPE(floor);
4346     return cv;
4347 }
4348
4349 /* XXX unsafe for threads if eval_owner isn't held */
4350 /*
4351 =for apidoc newCONSTSUB
4352
4353 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4354 eligible for inlining at compile-time.
4355
4356 =cut
4357 */
4358
4359 CV *
4360 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4361 {
4362     CV* cv;
4363
4364     ENTER;
4365
4366     SAVECOPLINE(PL_curcop);
4367     CopLINE_set(PL_curcop, PL_copline);
4368
4369     SAVEHINTS();
4370     PL_hints &= ~HINT_BLOCK_SCOPE;
4371
4372     if (stash) {
4373         SAVESPTR(PL_curstash);
4374         SAVECOPSTASH(PL_curcop);
4375         PL_curstash = stash;
4376         CopSTASH_set(PL_curcop,stash);
4377     }
4378
4379     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4380     CvXSUBANY(cv).any_ptr = sv;
4381     CvCONST_on(cv);
4382     sv_setpv((SV*)cv, "");  /* prototype is "" */
4383
4384     if (stash)
4385         CopSTASH_free(PL_curcop);
4386
4387     LEAVE;
4388
4389     return cv;
4390 }
4391
4392 /*
4393 =for apidoc U||newXS
4394
4395 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4396
4397 =cut
4398 */
4399
4400 CV *
4401 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4402 {
4403     GV *gv = gv_fetchpv(name ? name :
4404                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4405                         GV_ADDMULTI, SVt_PVCV);
4406     register CV *cv;
4407
4408     if (!subaddr)
4409         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4410
4411     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4412         if (GvCVGEN(gv)) {
4413             /* just a cached method */
4414             SvREFCNT_dec(cv);
4415             cv = 0;
4416         }
4417         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4418             /* already defined (or promised) */
4419             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4420                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4421                 line_t oldline = CopLINE(PL_curcop);
4422                 if (PL_copline != NOLINE)
4423                     CopLINE_set(PL_curcop, PL_copline);
4424                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4425                             CvCONST(cv) ? "Constant subroutine %s redefined"
4426                                         : "Subroutine %s redefined"
4427                             ,name);
4428                 CopLINE_set(PL_curcop, oldline);
4429             }
4430             SvREFCNT_dec(cv);
4431             cv = 0;
4432         }
4433     }
4434
4435     if (cv)                             /* must reuse cv if autoloaded */
4436         cv_undef(cv);
4437     else {
4438         cv = (CV*)NEWSV(1105,0);
4439         sv_upgrade((SV *)cv, SVt_PVCV);
4440         if (name) {
4441             GvCV(gv) = cv;
4442             GvCVGEN(gv) = 0;
4443             PL_sub_generation++;
4444         }
4445     }
4446     CvGV(cv) = gv;
4447     (void)gv_fetchfile(filename);
4448     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4449                                    an external constant string */
4450     CvXSUB(cv) = subaddr;
4451
4452     if (name) {
4453         char *s = strrchr(name,':');
4454         if (s)
4455             s++;
4456         else
4457             s = name;
4458
4459         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4460             goto done;
4461
4462         if (strEQ(s, "BEGIN")) {
4463             if (!PL_beginav)
4464                 PL_beginav = newAV();
4465             av_push(PL_beginav, (SV*)cv);
4466             GvCV(gv) = 0;               /* cv has been hijacked */
4467         }
4468         else if (strEQ(s, "END")) {
4469             if (!PL_endav)
4470                 PL_endav = newAV();
4471             av_unshift(PL_endav, 1);
4472             av_store(PL_endav, 0, (SV*)cv);
4473             GvCV(gv) = 0;               /* cv has been hijacked */
4474         }
4475         else if (strEQ(s, "CHECK")) {
4476             if (!PL_checkav)
4477                 PL_checkav = newAV();
4478             if (PL_main_start && ckWARN(WARN_VOID))
4479                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4480             av_unshift(PL_checkav, 1);
4481             av_store(PL_checkav, 0, (SV*)cv);
4482             GvCV(gv) = 0;               /* cv has been hijacked */
4483         }
4484         else if (strEQ(s, "INIT")) {
4485             if (!PL_initav)
4486                 PL_initav = newAV();
4487             if (PL_main_start && ckWARN(WARN_VOID))
4488                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4489             av_push(PL_initav, (SV*)cv);
4490             GvCV(gv) = 0;               /* cv has been hijacked */
4491         }
4492     }
4493     else
4494         CvANON_on(cv);
4495
4496 done:
4497     return cv;
4498 }
4499
4500 void
4501 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4502 {
4503     register CV *cv;
4504     char *name;
4505     GV *gv;
4506     STRLEN n_a;
4507
4508     if (o)
4509         name = SvPVx(cSVOPo->op_sv, n_a);
4510     else
4511         name = "STDOUT";
4512     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4513 #ifdef GV_UNIQUE_CHECK
4514     if (GvUNIQUE(gv)) {
4515         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4516     }
4517 #endif
4518     GvMULTI_on(gv);
4519     if ((cv = GvFORM(gv))) {
4520         if (ckWARN(WARN_REDEFINE)) {
4521             line_t oldline = CopLINE(PL_curcop);
4522             if (PL_copline != NOLINE)
4523                 CopLINE_set(PL_curcop, PL_copline);
4524             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4525             CopLINE_set(PL_curcop, oldline);
4526         }
4527         SvREFCNT_dec(cv);
4528     }
4529     cv = PL_compcv;
4530     GvFORM(gv) = cv;
4531     CvGV(cv) = gv;
4532     CvFILE_set_from_cop(cv, PL_curcop);
4533
4534
4535     pad_tidy(padtidy_FORMAT);
4536     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4537     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4538     OpREFCNT_set(CvROOT(cv), 1);
4539     CvSTART(cv) = LINKLIST(CvROOT(cv));
4540     CvROOT(cv)->op_next = 0;
4541     CALL_PEEP(CvSTART(cv));
4542     op_free(o);
4543     PL_copline = NOLINE;
4544     LEAVE_SCOPE(floor);
4545 }
4546
4547 OP *
4548 Perl_newANONLIST(pTHX_ OP *o)
4549 {
4550     return newUNOP(OP_REFGEN, 0,
4551         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4552 }
4553
4554 OP *
4555 Perl_newANONHASH(pTHX_ OP *o)
4556 {
4557     return newUNOP(OP_REFGEN, 0,
4558         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4559 }
4560
4561 OP *
4562 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4563 {
4564     return newANONATTRSUB(floor, proto, Nullop, block);
4565 }
4566
4567 OP *
4568 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4569 {
4570     return newUNOP(OP_REFGEN, 0,
4571         newSVOP(OP_ANONCODE, 0,
4572                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4573 }
4574
4575 OP *
4576 Perl_oopsAV(pTHX_ OP *o)
4577 {
4578     switch (o->op_type) {
4579     case OP_PADSV:
4580         o->op_type = OP_PADAV;
4581         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4582         return ref(o, OP_RV2AV);
4583
4584     case OP_RV2SV:
4585         o->op_type = OP_RV2AV;
4586         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4587         ref(o, OP_RV2AV);
4588         break;
4589
4590     default:
4591         if (ckWARN_d(WARN_INTERNAL))
4592             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4593         break;
4594     }
4595     return o;
4596 }
4597
4598 OP *
4599 Perl_oopsHV(pTHX_ OP *o)
4600 {
4601     switch (o->op_type) {
4602     case OP_PADSV:
4603     case OP_PADAV:
4604         o->op_type = OP_PADHV;
4605         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4606         return ref(o, OP_RV2HV);
4607
4608     case OP_RV2SV:
4609     case OP_RV2AV:
4610         o->op_type = OP_RV2HV;
4611         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4612         ref(o, OP_RV2HV);
4613         break;
4614
4615     default:
4616         if (ckWARN_d(WARN_INTERNAL))
4617             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4618         break;
4619     }
4620     return o;
4621 }
4622
4623 OP *
4624 Perl_newAVREF(pTHX_ OP *o)
4625 {
4626     if (o->op_type == OP_PADANY) {
4627         o->op_type = OP_PADAV;
4628         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4629         return o;
4630     }
4631     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4632                 && ckWARN(WARN_DEPRECATED)) {
4633         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4634                 "Using an array as a reference is deprecated");
4635     }
4636     return newUNOP(OP_RV2AV, 0, scalar(o));
4637 }
4638
4639 OP *
4640 Perl_newGVREF(pTHX_ I32 type, OP *o)
4641 {
4642     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4643         return newUNOP(OP_NULL, 0, o);
4644     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4645 }
4646
4647 OP *
4648 Perl_newHVREF(pTHX_ OP *o)
4649 {
4650     if (o->op_type == OP_PADANY) {
4651         o->op_type = OP_PADHV;
4652         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4653         return o;
4654     }
4655     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4656                 && ckWARN(WARN_DEPRECATED)) {
4657         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4658                 "Using a hash as a reference is deprecated");
4659     }
4660     return newUNOP(OP_RV2HV, 0, scalar(o));
4661 }
4662
4663 OP *
4664 Perl_oopsCV(pTHX_ OP *o)
4665 {
4666     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4667     /* STUB */
4668     return o;
4669 }
4670
4671 OP *
4672 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4673 {
4674     return newUNOP(OP_RV2CV, flags, scalar(o));
4675 }
4676
4677 OP *
4678 Perl_newSVREF(pTHX_ OP *o)
4679 {
4680     if (o->op_type == OP_PADANY) {
4681         o->op_type = OP_PADSV;
4682         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4683         return o;
4684     }
4685     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4686         o->op_flags |= OPpDONE_SVREF;
4687         return o;
4688     }
4689     return newUNOP(OP_RV2SV, 0, scalar(o));
4690 }
4691
4692 /* Check routines. */
4693
4694 OP *
4695 Perl_ck_anoncode(pTHX_ OP *o)
4696 {
4697     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4698     cSVOPo->op_sv = Nullsv;
4699     return o;
4700 }
4701
4702 OP *
4703 Perl_ck_bitop(pTHX_ OP *o)
4704 {
4705 #define OP_IS_NUMCOMPARE(op) \
4706         ((op) == OP_LT   || (op) == OP_I_LT || \
4707          (op) == OP_GT   || (op) == OP_I_GT || \
4708          (op) == OP_LE   || (op) == OP_I_LE || \
4709          (op) == OP_GE   || (op) == OP_I_GE || \
4710          (op) == OP_EQ   || (op) == OP_I_EQ || \
4711          (op) == OP_NE   || (op) == OP_I_NE || \
4712          (op) == OP_NCMP || (op) == OP_I_NCMP)
4713     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4714     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4715             && (o->op_type == OP_BIT_OR
4716              || o->op_type == OP_BIT_AND
4717              || o->op_type == OP_BIT_XOR))
4718     {
4719         OP * left = cBINOPo->op_first;
4720         OP * right = left->op_sibling;
4721         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4722                 (left->op_flags & OPf_PARENS) == 0) ||
4723             (OP_IS_NUMCOMPARE(right->op_type) &&
4724                 (right->op_flags & OPf_PARENS) == 0))
4725             if (ckWARN(WARN_PRECEDENCE))
4726                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4727                         "Possible precedence problem on bitwise %c operator",
4728                         o->op_type == OP_BIT_OR ? '|'
4729                             : o->op_type == OP_BIT_AND ? '&' : '^'
4730                         );
4731     }
4732     return o;
4733 }
4734
4735 OP *
4736 Perl_ck_concat(pTHX_ OP *o)
4737 {
4738     OP *kid = cUNOPo->op_first;
4739     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4740             !(kUNOP->op_first->op_flags & OPf_MOD))
4741         o->op_flags |= OPf_STACKED;
4742     return o;
4743 }
4744
4745 OP *
4746 Perl_ck_spair(pTHX_ OP *o)
4747 {
4748     if (o->op_flags & OPf_KIDS) {
4749         OP* newop;
4750         OP* kid;
4751         OPCODE type = o->op_type;
4752         o = modkids(ck_fun(o), type);
4753         kid = cUNOPo->op_first;
4754         newop = kUNOP->op_first->op_sibling;
4755         if (newop &&
4756             (newop->op_sibling ||
4757              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4758              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4759              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4760
4761             return o;
4762         }
4763         op_free(kUNOP->op_first);
4764         kUNOP->op_first = newop;
4765     }
4766     o->op_ppaddr = PL_ppaddr[++o->op_type];
4767     return ck_fun(o);
4768 }
4769
4770 OP *
4771 Perl_ck_delete(pTHX_ OP *o)
4772 {
4773     o = ck_fun(o);
4774     o->op_private = 0;
4775     if (o->op_flags & OPf_KIDS) {
4776         OP *kid = cUNOPo->op_first;
4777         switch (kid->op_type) {
4778         case OP_ASLICE:
4779             o->op_flags |= OPf_SPECIAL;
4780             /* FALL THROUGH */
4781         case OP_HSLICE:
4782             o->op_private |= OPpSLICE;
4783             break;
4784         case OP_AELEM:
4785             o->op_flags |= OPf_SPECIAL;
4786             /* FALL THROUGH */
4787         case OP_HELEM:
4788             break;
4789         default:
4790             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4791                   OP_DESC(o));
4792         }
4793         op_null(kid);
4794     }
4795     return o;
4796 }
4797
4798 OP *
4799 Perl_ck_die(pTHX_ OP *o)
4800 {
4801 #ifdef VMS
4802     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4803 #endif
4804     return ck_fun(o);
4805 }
4806
4807 OP *
4808 Perl_ck_eof(pTHX_ OP *o)
4809 {
4810     I32 type = o->op_type;
4811
4812     if (o->op_flags & OPf_KIDS) {
4813         if (cLISTOPo->op_first->op_type == OP_STUB) {
4814             op_free(o);
4815             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4816         }
4817         return ck_fun(o);
4818     }
4819     return o;
4820 }
4821
4822 OP *
4823 Perl_ck_eval(pTHX_ OP *o)
4824 {
4825     PL_hints |= HINT_BLOCK_SCOPE;
4826     if (o->op_flags & OPf_KIDS) {
4827         SVOP *kid = (SVOP*)cUNOPo->op_first;
4828
4829         if (!kid) {
4830             o->op_flags &= ~OPf_KIDS;
4831             op_null(o);
4832         }
4833         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4834             LOGOP *enter;
4835
4836             cUNOPo->op_first = 0;
4837             op_free(o);
4838
4839             NewOp(1101, enter, 1, LOGOP);
4840             enter->op_type = OP_ENTERTRY;
4841             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4842             enter->op_private = 0;
4843