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