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