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