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