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