This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
045b8d34b5f70bdbd8b282086315f3afcf946295
[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         if (attrs) {
1960             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1961             PL_in_my = FALSE;
1962             PL_in_my_stash = Nullhv;
1963             apply_attrs(GvSTASH(gv),
1964                         (type == OP_RV2SV ? GvSV(gv) :
1965                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1966                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1967                         attrs);
1968         }
1969         o->op_private |= OPpOUR_INTRO;
1970         return o;
1971     } else if (type != OP_PADSV &&
1972              type != OP_PADAV &&
1973              type != OP_PADHV &&
1974              type != OP_PUSHMARK)
1975     {
1976         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977                           PL_op_desc[o->op_type],
1978                           PL_in_my == KEY_our ? "our" : "my"));
1979         return o;
1980     }
1981     else if (attrs && type != OP_PUSHMARK) {
1982         HV *stash;
1983         SV *padsv;
1984         SV **namesvp;
1985
1986         PL_in_my = FALSE;
1987         PL_in_my_stash = Nullhv;
1988
1989         /* check for C<my Dog $spot> when deciding package */
1990         namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991         if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992             stash = SvSTASH(*namesvp);
1993         else
1994             stash = PL_curstash;
1995         padsv = PAD_SV(o->op_targ);
1996         apply_attrs(stash, padsv, attrs);
1997     }
1998     o->op_flags |= OPf_MOD;
1999     o->op_private |= OPpLVAL_INTRO;
2000     return o;
2001 }
2002
2003 OP *
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2005 {
2006     if (o->op_flags & OPf_PARENS)
2007         list(o);
2008     if (attrs)
2009         SAVEFREEOP(attrs);
2010     o = my_kid(o, attrs);
2011     PL_in_my = FALSE;
2012     PL_in_my_stash = Nullhv;
2013     return o;
2014 }
2015
2016 OP *
2017 Perl_my(pTHX_ OP *o)
2018 {
2019     return my_kid(o, Nullop);
2020 }
2021
2022 OP *
2023 Perl_sawparens(pTHX_ OP *o)
2024 {
2025     if (o)
2026         o->op_flags |= OPf_PARENS;
2027     return o;
2028 }
2029
2030 OP *
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2032 {
2033     OP *o;
2034
2035     if (ckWARN(WARN_MISC) &&
2036       (left->op_type == OP_RV2AV ||
2037        left->op_type == OP_RV2HV ||
2038        left->op_type == OP_PADAV ||
2039        left->op_type == OP_PADHV)) {
2040       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041                             right->op_type == OP_TRANS)
2042                            ? right->op_type : OP_MATCH];
2043       const char *sample = ((left->op_type == OP_RV2AV ||
2044                              left->op_type == OP_PADAV)
2045                             ? "@array" : "%hash");
2046       Perl_warner(aTHX_ WARN_MISC,
2047              "Applying %s to %s will act on scalar(%s)",
2048              desc, sample, sample);
2049     }
2050
2051     if (!(right->op_flags & OPf_STACKED) &&
2052        (right->op_type == OP_MATCH ||
2053         right->op_type == OP_SUBST ||
2054         right->op_type == OP_TRANS)) {
2055         right->op_flags |= OPf_STACKED;
2056         if (right->op_type != OP_MATCH &&
2057             ! (right->op_type == OP_TRANS &&
2058                right->op_private & OPpTRANS_IDENTICAL))
2059             left = mod(left, right->op_type);
2060         if (right->op_type == OP_TRANS)
2061             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2062         else
2063             o = prepend_elem(right->op_type, scalar(left), right);
2064         if (type == OP_NOT)
2065             return newUNOP(OP_NOT, 0, scalar(o));
2066         return o;
2067     }
2068     else
2069         return bind_match(type, left,
2070                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2071 }
2072
2073 OP *
2074 Perl_invert(pTHX_ OP *o)
2075 {
2076     if (!o)
2077         return o;
2078     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
2079     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2080 }
2081
2082 OP *
2083 Perl_scope(pTHX_ OP *o)
2084 {
2085     if (o) {
2086         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088             o->op_type = OP_LEAVE;
2089             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2090         }
2091         else {
2092             if (o->op_type == OP_LINESEQ) {
2093                 OP *kid;
2094                 o->op_type = OP_SCOPE;
2095                 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096                 kid = ((LISTOP*)o)->op_first;
2097                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2098                     null(kid);
2099             }
2100             else
2101                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2102         }
2103     }
2104     return o;
2105 }
2106
2107 void
2108 Perl_save_hints(pTHX)
2109 {
2110     SAVEI32(PL_hints);
2111     SAVESPTR(GvHV(PL_hintgv));
2112     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113     SAVEFREESV(GvHV(PL_hintgv));
2114 }
2115
2116 int
2117 Perl_block_start(pTHX_ int full)
2118 {
2119     int retval = PL_savestack_ix;
2120
2121     SAVEI32(PL_comppad_name_floor);
2122     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2123     if (full)
2124         PL_comppad_name_fill = PL_comppad_name_floor;
2125     if (PL_comppad_name_floor < 0)
2126         PL_comppad_name_floor = 0;
2127     SAVEI32(PL_min_intro_pending);
2128     SAVEI32(PL_max_intro_pending);
2129     PL_min_intro_pending = 0;
2130     SAVEI32(PL_comppad_name_fill);
2131     SAVEI32(PL_padix_floor);
2132     PL_padix_floor = PL_padix;
2133     PL_pad_reset_pending = FALSE;
2134     SAVEHINTS();
2135     PL_hints &= ~HINT_BLOCK_SCOPE;
2136     SAVESPTR(PL_compiling.cop_warnings);
2137     if (! specialWARN(PL_compiling.cop_warnings)) {
2138         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139         SAVEFREESV(PL_compiling.cop_warnings) ;
2140     }
2141     SAVESPTR(PL_compiling.cop_io);
2142     if (! specialCopIO(PL_compiling.cop_io)) {
2143         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144         SAVEFREESV(PL_compiling.cop_io) ;
2145     }
2146     return retval;
2147 }
2148
2149 OP*
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2151 {
2152     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153     OP* retval = scalarseq(seq);
2154     LEAVE_SCOPE(floor);
2155     PL_pad_reset_pending = FALSE;
2156     PL_compiling.op_private = PL_hints;
2157     if (needblockscope)
2158         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159     pad_leavemy(PL_comppad_name_fill);
2160     PL_cop_seqmax++;
2161     return retval;
2162 }
2163
2164 STATIC OP *
2165 S_newDEFSVOP(pTHX)
2166 {
2167 #ifdef USE_THREADS
2168     OP *o = newOP(OP_THREADSV, 0);
2169     o->op_targ = find_threadsv("_");
2170     return o;
2171 #else
2172     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2174 }
2175
2176 void
2177 Perl_newPROG(pTHX_ OP *o)
2178 {
2179     if (PL_in_eval) {
2180         if (PL_eval_root)
2181                 return;
2182         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183                                ((PL_in_eval & EVAL_KEEPERR)
2184                                 ? OPf_SPECIAL : 0), o);
2185         PL_eval_start = linklist(PL_eval_root);
2186         PL_eval_root->op_private |= OPpREFCOUNTED;
2187         OpREFCNT_set(PL_eval_root, 1);
2188         PL_eval_root->op_next = 0;
2189         peep(PL_eval_start);
2190     }
2191     else {
2192         if (!o)
2193             return;
2194         PL_main_root = scope(sawparens(scalarvoid(o)));
2195         PL_curcop = &PL_compiling;
2196         PL_main_start = LINKLIST(PL_main_root);
2197         PL_main_root->op_private |= OPpREFCOUNTED;
2198         OpREFCNT_set(PL_main_root, 1);
2199         PL_main_root->op_next = 0;
2200         peep(PL_main_start);
2201         PL_compcv = 0;
2202
2203         /* Register with debugger */
2204         if (PERLDB_INTER) {
2205             CV *cv = get_cv("DB::postponed", FALSE);
2206             if (cv) {
2207                 dSP;
2208                 PUSHMARK(SP);
2209                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2210                 PUTBACK;
2211                 call_sv((SV*)cv, G_DISCARD);
2212             }
2213         }
2214     }
2215 }
2216
2217 OP *
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2219 {
2220     if (o->op_flags & OPf_PARENS)
2221         list(o);
2222     else {
2223         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2224             char *s;
2225             for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226             if (*s == ';' || *s == '=')
2227                 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228                             "Parentheses missing around \"%s\" list",
2229                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2230         }
2231     }
2232     if (lex)
2233         o = my(o);
2234     else
2235         o = mod(o, OP_NULL);            /* a bit kludgey */
2236     PL_in_my = FALSE;
2237     PL_in_my_stash = Nullhv;
2238     return o;
2239 }
2240
2241 OP *
2242 Perl_jmaybe(pTHX_ OP *o)
2243 {
2244     if (o->op_type == OP_LIST) {
2245         OP *o2;
2246 #ifdef USE_THREADS
2247         o2 = newOP(OP_THREADSV, 0);
2248         o2->op_targ = find_threadsv(";");
2249 #else
2250         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2253     }
2254     return o;
2255 }
2256
2257 OP *
2258 Perl_fold_constants(pTHX_ register OP *o)
2259 {
2260     register OP *curop;
2261     I32 type = o->op_type;
2262     SV *sv;
2263
2264     if (PL_opargs[type] & OA_RETSCALAR)
2265         scalar(o);
2266     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267         o->op_targ = pad_alloc(type, SVs_PADTMP);
2268
2269     /* integerize op, unless it happens to be C<-foo>.
2270      * XXX should pp_i_negate() do magic string negation instead? */
2271     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2274     {
2275         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2276     }
2277
2278     if (!(PL_opargs[type] & OA_FOLDCONST))
2279         goto nope;
2280
2281     switch (type) {
2282     case OP_NEGATE:
2283         /* XXX might want a ck_negate() for this */
2284         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2285         break;
2286     case OP_SPRINTF:
2287     case OP_UCFIRST:
2288     case OP_LCFIRST:
2289     case OP_UC:
2290     case OP_LC:
2291     case OP_SLT:
2292     case OP_SGT:
2293     case OP_SLE:
2294     case OP_SGE:
2295     case OP_SCMP:
2296
2297         if (o->op_private & OPpLOCALE)
2298             goto nope;
2299     }
2300
2301     if (PL_error_count)
2302         goto nope;              /* Don't try to run w/ errors */
2303
2304     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305         if ((curop->op_type != OP_CONST ||
2306              (curop->op_private & OPpCONST_BARE)) &&
2307             curop->op_type != OP_LIST &&
2308             curop->op_type != OP_SCALAR &&
2309             curop->op_type != OP_NULL &&
2310             curop->op_type != OP_PUSHMARK)
2311         {
2312             goto nope;
2313         }
2314     }
2315
2316     curop = LINKLIST(o);
2317     o->op_next = 0;
2318     PL_op = curop;
2319     CALLRUNOPS(aTHX);
2320     sv = *(PL_stack_sp--);
2321     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322         pad_swipe(o->op_targ);
2323     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2324         (void)SvREFCNT_inc(sv);
2325         SvTEMP_off(sv);
2326     }
2327     op_free(o);
2328     if (type == OP_RV2GV)
2329         return newGVOP(OP_GV, 0, (GV*)sv);
2330     else {
2331         /* try to smush double to int, but don't smush -2.0 to -2 */
2332         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2333             type != OP_NEGATE)
2334         {
2335 #ifdef PERL_PRESERVE_IVUV
2336             /* Only bother to attempt to fold to IV if
2337                most operators will benefit  */
2338             SvIV_please(sv);
2339 #endif
2340         }
2341         return newSVOP(OP_CONST, 0, sv);
2342     }
2343
2344   nope:
2345     if (!(PL_opargs[type] & OA_OTHERINT))
2346         return o;
2347
2348     if (!(PL_hints & HINT_INTEGER)) {
2349         if (type == OP_MODULO
2350             || type == OP_DIVIDE
2351             || !(o->op_flags & OPf_KIDS))
2352         {
2353             return o;
2354         }
2355
2356         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357             if (curop->op_type == OP_CONST) {
2358                 if (SvIOK(((SVOP*)curop)->op_sv))
2359                     continue;
2360                 return o;
2361             }
2362             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2363                 continue;
2364             return o;
2365         }
2366         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2367     }
2368
2369     return o;
2370 }
2371
2372 OP *
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2374 {
2375     register OP *curop;
2376     I32 oldtmps_floor = PL_tmps_floor;
2377
2378     list(o);
2379     if (PL_error_count)
2380         return o;               /* Don't attempt to run with errors */
2381
2382     PL_op = curop = LINKLIST(o);
2383     o->op_next = 0;
2384     peep(curop);
2385     pp_pushmark();
2386     CALLRUNOPS(aTHX);
2387     PL_op = curop;
2388     pp_anonlist();
2389     PL_tmps_floor = oldtmps_floor;
2390
2391     o->op_type = OP_RV2AV;
2392     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393     curop = ((UNOP*)o)->op_first;
2394     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2395     op_free(curop);
2396     linklist(o);
2397     return list(o);
2398 }
2399
2400 OP *
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2402 {
2403     if (!o || o->op_type != OP_LIST)
2404         o = newLISTOP(OP_LIST, 0, o, Nullop);
2405     else
2406         o->op_flags &= ~OPf_WANT;
2407
2408     if (!(PL_opargs[type] & OA_MARK))
2409         null(cLISTOPo->op_first);
2410
2411     o->op_type = type;
2412     o->op_ppaddr = PL_ppaddr[type];
2413     o->op_flags |= flags;
2414
2415     o = CHECKOP(type, o);
2416     if (o->op_type != type)
2417         return o;
2418
2419     return fold_constants(o);
2420 }
2421
2422 /* List constructors */
2423
2424 OP *
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2426 {
2427     if (!first)
2428         return last;
2429
2430     if (!last)
2431         return first;
2432
2433     if (first->op_type != type
2434         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2435     {
2436         return newLISTOP(type, 0, first, last);
2437     }
2438
2439     if (first->op_flags & OPf_KIDS)
2440         ((LISTOP*)first)->op_last->op_sibling = last;
2441     else {
2442         first->op_flags |= OPf_KIDS;
2443         ((LISTOP*)first)->op_first = last;
2444     }
2445     ((LISTOP*)first)->op_last = last;
2446     return first;
2447 }
2448
2449 OP *
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2451 {
2452     if (!first)
2453         return (OP*)last;
2454
2455     if (!last)
2456         return (OP*)first;
2457
2458     if (first->op_type != type)
2459         return prepend_elem(type, (OP*)first, (OP*)last);
2460
2461     if (last->op_type != type)
2462         return append_elem(type, (OP*)first, (OP*)last);
2463
2464     first->op_last->op_sibling = last->op_first;
2465     first->op_last = last->op_last;
2466     first->op_flags |= (last->op_flags & OPf_KIDS);
2467
2468 #ifdef PL_OP_SLAB_ALLOC
2469 #else
2470     Safefree(last);
2471 #endif
2472     return (OP*)first;
2473 }
2474
2475 OP *
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2477 {
2478     if (!first)
2479         return last;
2480
2481     if (!last)
2482         return first;
2483
2484     if (last->op_type == type) {
2485         if (type == OP_LIST) {  /* already a PUSHMARK there */
2486             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487             ((LISTOP*)last)->op_first->op_sibling = first;
2488             if (!(first->op_flags & OPf_PARENS))
2489                 last->op_flags &= ~OPf_PARENS;
2490         }
2491         else {
2492             if (!(last->op_flags & OPf_KIDS)) {
2493                 ((LISTOP*)last)->op_last = first;
2494                 last->op_flags |= OPf_KIDS;
2495             }
2496             first->op_sibling = ((LISTOP*)last)->op_first;
2497             ((LISTOP*)last)->op_first = first;
2498         }
2499         last->op_flags |= OPf_KIDS;
2500         return last;
2501     }
2502
2503     return newLISTOP(type, 0, first, last);
2504 }
2505
2506 /* Constructors */
2507
2508 OP *
2509 Perl_newNULLLIST(pTHX)
2510 {
2511     return newOP(OP_STUB, 0);
2512 }
2513
2514 OP *
2515 Perl_force_list(pTHX_ OP *o)
2516 {
2517     if (!o || o->op_type != OP_LIST)
2518         o = newLISTOP(OP_LIST, 0, o, Nullop);
2519     null(o);
2520     return o;
2521 }
2522
2523 OP *
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2525 {
2526     LISTOP *listop;
2527
2528     NewOp(1101, listop, 1, LISTOP);
2529
2530     listop->op_type = type;
2531     listop->op_ppaddr = PL_ppaddr[type];
2532     if (first || last)
2533         flags |= OPf_KIDS;
2534     listop->op_flags = flags;
2535
2536     if (!last && first)
2537         last = first;
2538     else if (!first && last)
2539         first = last;
2540     else if (first)
2541         first->op_sibling = last;
2542     listop->op_first = first;
2543     listop->op_last = last;
2544     if (type == OP_LIST) {
2545         OP* pushop;
2546         pushop = newOP(OP_PUSHMARK, 0);
2547         pushop->op_sibling = first;
2548         listop->op_first = pushop;
2549         listop->op_flags |= OPf_KIDS;
2550         if (!last)
2551             listop->op_last = pushop;
2552     }
2553
2554     return (OP*)listop;
2555 }
2556
2557 OP *
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2559 {
2560     OP *o;
2561     NewOp(1101, o, 1, OP);
2562     o->op_type = type;
2563     o->op_ppaddr = PL_ppaddr[type];
2564     o->op_flags = flags;
2565
2566     o->op_next = o;
2567     o->op_private = 0 + (flags >> 8);
2568     if (PL_opargs[type] & OA_RETSCALAR)
2569         scalar(o);
2570     if (PL_opargs[type] & OA_TARGET)
2571         o->op_targ = pad_alloc(type, SVs_PADTMP);
2572     return CHECKOP(type, o);
2573 }
2574
2575 OP *
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2577 {
2578     UNOP *unop;
2579
2580     if (!first)
2581         first = newOP(OP_STUB, 0);
2582     if (PL_opargs[type] & OA_MARK)
2583         first = force_list(first);
2584
2585     NewOp(1101, unop, 1, UNOP);
2586     unop->op_type = type;
2587     unop->op_ppaddr = PL_ppaddr[type];
2588     unop->op_first = first;
2589     unop->op_flags = flags | OPf_KIDS;
2590     unop->op_private = 1 | (flags >> 8);
2591     unop = (UNOP*) CHECKOP(type, unop);
2592     if (unop->op_next)
2593         return (OP*)unop;
2594
2595     return fold_constants((OP *) unop);
2596 }
2597
2598 OP *
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2600 {
2601     BINOP *binop;
2602     NewOp(1101, binop, 1, BINOP);
2603
2604     if (!first)
2605         first = newOP(OP_NULL, 0);
2606
2607     binop->op_type = type;
2608     binop->op_ppaddr = PL_ppaddr[type];
2609     binop->op_first = first;
2610     binop->op_flags = flags | OPf_KIDS;
2611     if (!last) {
2612         last = first;
2613         binop->op_private = 1 | (flags >> 8);
2614     }
2615     else {
2616         binop->op_private = 2 | (flags >> 8);
2617         first->op_sibling = last;
2618     }
2619
2620     binop = (BINOP*)CHECKOP(type, binop);
2621     if (binop->op_next || binop->op_type != type)
2622         return (OP*)binop;
2623
2624     binop->op_last = binop->op_first->op_sibling;
2625
2626     return fold_constants((OP *)binop);
2627 }
2628
2629 static int
2630 utf8compare(const void *a, const void *b)
2631 {
2632     int i;
2633     for (i = 0; i < 10; i++) {
2634         if ((*(U8**)a)[i] < (*(U8**)b)[i])
2635             return -1;
2636         if ((*(U8**)a)[i] > (*(U8**)b)[i])
2637             return 1;
2638     }
2639     return 0;
2640 }
2641
2642 OP *
2643 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2644 {
2645     SV *tstr = ((SVOP*)expr)->op_sv;
2646     SV *rstr = ((SVOP*)repl)->op_sv;
2647     STRLEN tlen;
2648     STRLEN rlen;
2649     U8 *t = (U8*)SvPV(tstr, tlen);
2650     U8 *r = (U8*)SvPV(rstr, rlen);
2651     register I32 i;
2652     register I32 j;
2653     I32 del;
2654     I32 complement;
2655     I32 squash;
2656     I32 grows = 0;
2657     register short *tbl;
2658
2659     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2660     del         = o->op_private & OPpTRANS_DELETE;
2661     squash      = o->op_private & OPpTRANS_SQUASH;
2662
2663     if (SvUTF8(tstr))
2664         o->op_private |= OPpTRANS_FROM_UTF;
2665
2666     if (SvUTF8(rstr))
2667         o->op_private |= OPpTRANS_TO_UTF;
2668
2669     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2670         SV* listsv = newSVpvn("# comment\n",10);
2671         SV* transv = 0;
2672         U8* tend = t + tlen;
2673         U8* rend = r + rlen;
2674         STRLEN ulen;
2675         U32 tfirst = 1;
2676         U32 tlast = 0;
2677         I32 tdiff;
2678         U32 rfirst = 1;
2679         U32 rlast = 0;
2680         I32 rdiff;
2681         I32 diff;
2682         I32 none = 0;
2683         U32 max = 0;
2684         I32 bits;
2685         I32 havefinal = 0;
2686         U32 final;
2687         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2688         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2689         U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2690         U8* rsave = to_utf   ? NULL : trlist_upgrade(&r, &rend);
2691
2692         if (complement) {
2693             U8 tmpbuf[UTF8_MAXLEN+1];
2694             U8** cp;
2695             UV nextmin = 0;
2696             New(1109, cp, tlen, U8*);
2697             i = 0;
2698             transv = newSVpvn("",0);
2699             while (t < tend) {
2700                 cp[i++] = t;
2701                 t += UTF8SKIP(t);
2702                 if (t < tend && *t == 0xff) {
2703                     t++;
2704                     t += UTF8SKIP(t);
2705                 }
2706             }
2707             qsort(cp, i, sizeof(U8*), utf8compare);
2708             for (j = 0; j < i; j++) {
2709                 U8 *s = cp[j];
2710                 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2711                 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2712                 UV  val = utf8n_to_uvuni(s, cur, &ulen, 0);
2713                 s += ulen;
2714                 diff = val - nextmin;
2715                 if (diff > 0) {
2716                     t = uvuni_to_utf8(tmpbuf,nextmin);
2717                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2718                     if (diff > 1) {
2719                         t = uvuni_to_utf8(tmpbuf, val - 1);
2720                         sv_catpvn(transv, "\377", 1);
2721                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2722                     }
2723                 }
2724                 if (s < tend && *s == 0xff)
2725                     val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2726                 if (val >= nextmin)
2727                     nextmin = val + 1;
2728             }
2729             t = uvuni_to_utf8(tmpbuf,nextmin);
2730             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2732             sv_catpvn(transv, "\377", 1);
2733             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2734             t = (U8*)SvPVX(transv);
2735             tlen = SvCUR(transv);
2736             tend = t + tlen;
2737             Safefree(cp);
2738         }
2739         else if (!rlen && !del) {
2740             r = t; rlen = tlen; rend = tend;
2741         }
2742         if (!squash) {
2743                 if ((!rlen && !del) || t == r ||
2744                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2745                 {
2746                     o->op_private |= OPpTRANS_IDENTICAL;
2747                 }
2748         }
2749
2750         while (t < tend || tfirst <= tlast) {
2751             /* see if we need more "t" chars */
2752             if (tfirst > tlast) {
2753                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2754                 t += ulen;
2755                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2756                     t++;
2757                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2758                     t += ulen;
2759                 }
2760                 else
2761                     tlast = tfirst;
2762             }
2763
2764             /* now see if we need more "r" chars */
2765             if (rfirst > rlast) {
2766                 if (r < rend) {
2767                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2768                     r += ulen;
2769                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2770                         r++;
2771                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2772                         r += ulen;
2773                     }
2774                     else
2775                         rlast = rfirst;
2776                 }
2777                 else {
2778                     if (!havefinal++)
2779                         final = rlast;
2780                     rfirst = rlast = 0xffffffff;
2781                 }
2782             }
2783
2784             /* now see which range will peter our first, if either. */
2785             tdiff = tlast - tfirst;
2786             rdiff = rlast - rfirst;
2787
2788             if (tdiff <= rdiff)
2789                 diff = tdiff;
2790             else
2791                 diff = rdiff;
2792
2793             if (rfirst == 0xffffffff) {
2794                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2795                 if (diff > 0)
2796                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2797                                    (long)tfirst, (long)tlast);
2798                 else
2799                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2800             }
2801             else {
2802                 if (diff > 0)
2803                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2804                                    (long)tfirst, (long)(tfirst + diff),
2805                                    (long)rfirst);
2806                 else
2807                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2808                                    (long)tfirst, (long)rfirst);
2809
2810                 if (rfirst + diff > max)
2811                     max = rfirst + diff;
2812                 rfirst += diff + 1;
2813                 if (!grows)
2814                     grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2815             }
2816             tfirst += diff + 1;
2817         }
2818
2819         none = ++max;
2820         if (del)
2821             del = ++max;
2822
2823         if (max > 0xffff)
2824             bits = 32;
2825         else if (max > 0xff)
2826             bits = 16;
2827         else
2828             bits = 8;
2829
2830         Safefree(cPVOPo->op_pv);
2831         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2832         SvREFCNT_dec(listsv);
2833         if (transv)
2834             SvREFCNT_dec(transv);
2835
2836         if (!del && havefinal)
2837             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2838                            newSVuv((UV)final), 0);
2839
2840         if (grows)
2841             o->op_private |= OPpTRANS_GROWS;
2842
2843         if (tsave)
2844             Safefree(tsave);
2845         if (rsave)
2846             Safefree(rsave);
2847
2848         op_free(expr);
2849         op_free(repl);
2850         return o;
2851     }
2852
2853     tbl = (short*)cPVOPo->op_pv;
2854     if (complement) {
2855         Zero(tbl, 256, short);
2856         for (i = 0; i < tlen; i++)
2857             tbl[t[i]] = -1;
2858         for (i = 0, j = 0; i < 256; i++) {
2859             if (!tbl[i]) {
2860                 if (j >= rlen) {
2861                     if (del)
2862                         tbl[i] = -2;
2863                     else if (rlen)
2864                         tbl[i] = r[j-1];
2865                     else
2866                         tbl[i] = i;
2867                 }
2868                 else {
2869                     if (i < 128 && r[j] >= 128)
2870                         grows = 1;
2871                     tbl[i] = r[j++];
2872                 }
2873             }
2874         }
2875         if (!del) {
2876             if (!rlen) {
2877                 j = rlen;
2878                 if (!squash)
2879                     o->op_private |= OPpTRANS_IDENTICAL;
2880             }
2881             else if (j >= rlen)
2882                 j = rlen - 1;
2883             else
2884                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2885             tbl[0x100] = rlen - j;
2886             for (i=0; i < rlen - j; i++)
2887                 tbl[0x101+i] = r[j+i];
2888         }
2889     }
2890     else {
2891         if (!rlen && !del) {
2892             r = t; rlen = tlen;
2893             if (!squash)
2894                 o->op_private |= OPpTRANS_IDENTICAL;
2895         }
2896         for (i = 0; i < 256; i++)
2897             tbl[i] = -1;
2898         for (i = 0, j = 0; i < tlen; i++,j++) {
2899             if (j >= rlen) {
2900                 if (del) {
2901                     if (tbl[t[i]] == -1)
2902                         tbl[t[i]] = -2;
2903                     continue;
2904                 }
2905                 --j;
2906             }
2907             if (tbl[t[i]] == -1) {
2908                 if (t[i] < 128 && r[j] >= 128)
2909                     grows = 1;
2910                 tbl[t[i]] = r[j];
2911             }
2912         }
2913     }
2914     if (grows)
2915         o->op_private |= OPpTRANS_GROWS;
2916     op_free(expr);
2917     op_free(repl);
2918
2919     return o;
2920 }
2921
2922 OP *
2923 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2924 {
2925     PMOP *pmop;
2926
2927     NewOp(1101, pmop, 1, PMOP);
2928     pmop->op_type = type;
2929     pmop->op_ppaddr = PL_ppaddr[type];
2930     pmop->op_flags = flags;
2931     pmop->op_private = 0 | (flags >> 8);
2932
2933     if (PL_hints & HINT_RE_TAINT)
2934         pmop->op_pmpermflags |= PMf_RETAINT;
2935     if (PL_hints & HINT_LOCALE)
2936         pmop->op_pmpermflags |= PMf_LOCALE;
2937     pmop->op_pmflags = pmop->op_pmpermflags;
2938
2939     /* link into pm list */
2940     if (type != OP_TRANS && PL_curstash) {
2941         pmop->op_pmnext = HvPMROOT(PL_curstash);
2942         HvPMROOT(PL_curstash) = pmop;
2943     }
2944
2945     return (OP*)pmop;
2946 }
2947
2948 OP *
2949 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2950 {
2951     PMOP *pm;
2952     LOGOP *rcop;
2953     I32 repl_has_vars = 0;
2954
2955     if (o->op_type == OP_TRANS)
2956         return pmtrans(o, expr, repl);
2957
2958     PL_hints |= HINT_BLOCK_SCOPE;
2959     pm = (PMOP*)o;
2960
2961     if (expr->op_type == OP_CONST) {
2962         STRLEN plen;
2963         SV *pat = ((SVOP*)expr)->op_sv;
2964         char *p = SvPV(pat, plen);
2965         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2966             sv_setpvn(pat, "\\s+", 3);
2967             p = SvPV(pat, plen);
2968             pm->op_pmflags |= PMf_SKIPWHITE;
2969         }
2970         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2971             pm->op_pmdynflags |= PMdf_UTF8;
2972         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2973         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2974             pm->op_pmflags |= PMf_WHITE;
2975         op_free(expr);
2976     }
2977     else {
2978         if (PL_hints & HINT_UTF8)
2979             pm->op_pmdynflags |= PMdf_UTF8;
2980         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2981             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2982                             ? OP_REGCRESET
2983                             : OP_REGCMAYBE),0,expr);
2984
2985         NewOp(1101, rcop, 1, LOGOP);
2986         rcop->op_type = OP_REGCOMP;
2987         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2988         rcop->op_first = scalar(expr);
2989         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2990                            ? (OPf_SPECIAL | OPf_KIDS)
2991                            : OPf_KIDS);
2992         rcop->op_private = 1;
2993         rcop->op_other = o;
2994
2995         /* establish postfix order */
2996         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2997             LINKLIST(expr);
2998             rcop->op_next = expr;
2999             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3000         }
3001         else {
3002             rcop->op_next = LINKLIST(expr);
3003             expr->op_next = (OP*)rcop;
3004         }
3005
3006         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3007     }
3008
3009     if (repl) {
3010         OP *curop;
3011         if (pm->op_pmflags & PMf_EVAL) {
3012             curop = 0;
3013             if (CopLINE(PL_curcop) < PL_multi_end)
3014                 CopLINE_set(PL_curcop, PL_multi_end);
3015         }
3016 #ifdef USE_THREADS
3017         else if (repl->op_type == OP_THREADSV
3018                  && strchr("&`'123456789+",
3019                            PL_threadsv_names[repl->op_targ]))
3020         {
3021             curop = 0;
3022         }
3023 #endif /* USE_THREADS */
3024         else if (repl->op_type == OP_CONST)
3025             curop = repl;
3026         else {
3027             OP *lastop = 0;
3028             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3029                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3030 #ifdef USE_THREADS
3031                     if (curop->op_type == OP_THREADSV) {
3032                         repl_has_vars = 1;
3033                         if (strchr("&`'123456789+", curop->op_private))
3034                             break;
3035                     }
3036 #else
3037                     if (curop->op_type == OP_GV) {
3038                         GV *gv = cGVOPx_gv(curop);
3039                         repl_has_vars = 1;
3040                         if (strchr("&`'123456789+", *GvENAME(gv)))
3041                             break;
3042                     }
3043 #endif /* USE_THREADS */
3044                     else if (curop->op_type == OP_RV2CV)
3045                         break;
3046                     else if (curop->op_type == OP_RV2SV ||
3047                              curop->op_type == OP_RV2AV ||
3048                              curop->op_type == OP_RV2HV ||
3049                              curop->op_type == OP_RV2GV) {
3050                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3051                             break;
3052                     }
3053                     else if (curop->op_type == OP_PADSV ||
3054                              curop->op_type == OP_PADAV ||
3055                              curop->op_type == OP_PADHV ||
3056                              curop->op_type == OP_PADANY) {
3057                         repl_has_vars = 1;
3058                     }
3059                     else if (curop->op_type == OP_PUSHRE)
3060                         ; /* Okay here, dangerous in newASSIGNOP */
3061                     else
3062                         break;
3063                 }
3064                 lastop = curop;
3065             }
3066         }
3067         if (curop == repl
3068             && !(repl_has_vars
3069                  && (!pm->op_pmregexp
3070                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3071             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3072             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3073             prepend_elem(o->op_type, scalar(repl), o);
3074         }
3075         else {
3076             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3077                 pm->op_pmflags |= PMf_MAYBE_CONST;
3078                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3079             }
3080             NewOp(1101, rcop, 1, LOGOP);
3081             rcop->op_type = OP_SUBSTCONT;
3082             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3083             rcop->op_first = scalar(repl);
3084             rcop->op_flags |= OPf_KIDS;
3085             rcop->op_private = 1;
3086             rcop->op_other = o;
3087
3088             /* establish postfix order */
3089             rcop->op_next = LINKLIST(repl);
3090             repl->op_next = (OP*)rcop;
3091
3092             pm->op_pmreplroot = scalar((OP*)rcop);
3093             pm->op_pmreplstart = LINKLIST(rcop);
3094             rcop->op_next = 0;
3095         }
3096     }
3097
3098     return (OP*)pm;
3099 }
3100
3101 OP *
3102 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3103 {
3104     SVOP *svop;
3105     NewOp(1101, svop, 1, SVOP);
3106     svop->op_type = type;
3107     svop->op_ppaddr = PL_ppaddr[type];
3108     svop->op_sv = sv;
3109     svop->op_next = (OP*)svop;
3110     svop->op_flags = flags;
3111     if (PL_opargs[type] & OA_RETSCALAR)
3112         scalar((OP*)svop);
3113     if (PL_opargs[type] & OA_TARGET)
3114         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3115     return CHECKOP(type, svop);
3116 }
3117
3118 OP *
3119 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3120 {
3121     PADOP *padop;
3122     NewOp(1101, padop, 1, PADOP);
3123     padop->op_type = type;
3124     padop->op_ppaddr = PL_ppaddr[type];
3125     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3126     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3127     PL_curpad[padop->op_padix] = sv;
3128     SvPADTMP_on(sv);
3129     padop->op_next = (OP*)padop;
3130     padop->op_flags = flags;
3131     if (PL_opargs[type] & OA_RETSCALAR)
3132         scalar((OP*)padop);
3133     if (PL_opargs[type] & OA_TARGET)
3134         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3135     return CHECKOP(type, padop);
3136 }
3137
3138 OP *
3139 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3140 {
3141 #ifdef USE_ITHREADS
3142     GvIN_PAD_on(gv);
3143     return newPADOP(type, flags, SvREFCNT_inc(gv));
3144 #else
3145     return newSVOP(type, flags, SvREFCNT_inc(gv));
3146 #endif
3147 }
3148
3149 OP *
3150 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3151 {
3152     PVOP *pvop;
3153     NewOp(1101, pvop, 1, PVOP);
3154     pvop->op_type = type;
3155     pvop->op_ppaddr = PL_ppaddr[type];
3156     pvop->op_pv = pv;
3157     pvop->op_next = (OP*)pvop;
3158     pvop->op_flags = flags;
3159     if (PL_opargs[type] & OA_RETSCALAR)
3160         scalar((OP*)pvop);
3161     if (PL_opargs[type] & OA_TARGET)
3162         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3163     return CHECKOP(type, pvop);
3164 }
3165
3166 void
3167 Perl_package(pTHX_ OP *o)
3168 {
3169     SV *sv;
3170
3171     save_hptr(&PL_curstash);
3172     save_item(PL_curstname);
3173     if (o) {
3174         STRLEN len;
3175         char *name;
3176         sv = cSVOPo->op_sv;
3177         name = SvPV(sv, len);
3178         PL_curstash = gv_stashpvn(name,len,TRUE);
3179         sv_setpvn(PL_curstname, name, len);
3180         op_free(o);
3181     }
3182     else {
3183         sv_setpv(PL_curstname,"<none>");
3184         PL_curstash = Nullhv;
3185     }
3186     PL_hints |= HINT_BLOCK_SCOPE;
3187     PL_copline = NOLINE;
3188     PL_expect = XSTATE;
3189 }
3190
3191 void
3192 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3193 {
3194     OP *pack;
3195     OP *rqop;
3196     OP *imop;
3197     OP *veop;
3198     GV *gv;
3199
3200     if (id->op_type != OP_CONST)
3201         Perl_croak(aTHX_ "Module name must be constant");
3202
3203     veop = Nullop;
3204
3205     if (version != Nullop) {
3206         SV *vesv = ((SVOP*)version)->op_sv;
3207
3208         if (arg == Nullop && !SvNIOKp(vesv)) {
3209             arg = version;
3210         }
3211         else {
3212             OP *pack;
3213             SV *meth;
3214
3215             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3216                 Perl_croak(aTHX_ "Version number must be constant number");
3217
3218             /* Make copy of id so we don't free it twice */
3219             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3220
3221             /* Fake up a method call to VERSION */
3222             meth = newSVpvn("VERSION",7);
3223             sv_upgrade(meth, SVt_PVIV);
3224             (void)SvIOK_on(meth);
3225             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3226             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3227                             append_elem(OP_LIST,
3228                                         prepend_elem(OP_LIST, pack, list(version)),
3229                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3230         }
3231     }
3232
3233     /* Fake up an import/unimport */
3234     if (arg && arg->op_type == OP_STUB)
3235         imop = arg;             /* no import on explicit () */
3236     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3237         imop = Nullop;          /* use 5.0; */
3238     }
3239     else {
3240         SV *meth;
3241
3242         /* Make copy of id so we don't free it twice */
3243         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3244
3245         /* Fake up a method call to import/unimport */
3246         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3247         sv_upgrade(meth, SVt_PVIV);
3248         (void)SvIOK_on(meth);
3249         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3250         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3251                        append_elem(OP_LIST,
3252                                    prepend_elem(OP_LIST, pack, list(arg)),
3253                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3254     }
3255
3256     /* Fake up a require, handle override, if any */
3257     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3258     if (!(gv && GvIMPORTED_CV(gv)))
3259         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3260
3261     if (gv && GvIMPORTED_CV(gv)) {
3262         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3263                                append_elem(OP_LIST, id,
3264                                            scalar(newUNOP(OP_RV2CV, 0,
3265                                                           newGVOP(OP_GV, 0,
3266                                                                   gv))))));
3267     }
3268     else {
3269         rqop = newUNOP(OP_REQUIRE, 0, id);
3270     }
3271
3272     /* Fake up the BEGIN {}, which does its thing immediately. */
3273     newATTRSUB(floor,
3274         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3275         Nullop,
3276         Nullop,
3277         append_elem(OP_LINESEQ,
3278             append_elem(OP_LINESEQ,
3279                 newSTATEOP(0, Nullch, rqop),
3280                 newSTATEOP(0, Nullch, veop)),
3281             newSTATEOP(0, Nullch, imop) ));
3282
3283     PL_hints |= HINT_BLOCK_SCOPE;
3284     PL_copline = NOLINE;
3285     PL_expect = XSTATE;
3286 }
3287
3288 void
3289 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3290 {
3291     va_list args;
3292     va_start(args, ver);
3293     vload_module(flags, name, ver, &args);
3294     va_end(args);
3295 }
3296
3297 #ifdef PERL_IMPLICIT_CONTEXT
3298 void
3299 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3300 {
3301     dTHX;
3302     va_list args;
3303     va_start(args, ver);
3304     vload_module(flags, name, ver, &args);
3305     va_end(args);
3306 }
3307 #endif
3308
3309 void
3310 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3311 {
3312     OP *modname, *veop, *imop;
3313
3314     modname = newSVOP(OP_CONST, 0, name);
3315     modname->op_private |= OPpCONST_BARE;
3316     if (ver) {
3317         veop = newSVOP(OP_CONST, 0, ver);
3318     }
3319     else
3320         veop = Nullop;
3321     if (flags & PERL_LOADMOD_NOIMPORT) {
3322         imop = sawparens(newNULLLIST());
3323     }
3324     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3325         imop = va_arg(*args, OP*);
3326     }
3327     else {
3328         SV *sv;
3329         imop = Nullop;
3330         sv = va_arg(*args, SV*);
3331         while (sv) {
3332             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3333             sv = va_arg(*args, SV*);
3334         }
3335     }
3336     {
3337         line_t ocopline = PL_copline;
3338         int oexpect = PL_expect;
3339
3340         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3341                 veop, modname, imop);
3342         PL_expect = oexpect;
3343         PL_copline = ocopline;
3344     }
3345 }
3346
3347 OP *
3348 Perl_dofile(pTHX_ OP *term)
3349 {
3350     OP *doop;
3351     GV *gv;
3352
3353     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3354     if (!(gv && GvIMPORTED_CV(gv)))
3355         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3356
3357     if (gv && GvIMPORTED_CV(gv)) {
3358         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3359                                append_elem(OP_LIST, term,
3360                                            scalar(newUNOP(OP_RV2CV, 0,
3361                                                           newGVOP(OP_GV, 0,
3362                                                                   gv))))));
3363     }
3364     else {
3365         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3366     }
3367     return doop;
3368 }
3369
3370 OP *
3371 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3372 {
3373     return newBINOP(OP_LSLICE, flags,
3374             list(force_list(subscript)),
3375             list(force_list(listval)) );
3376 }
3377
3378 STATIC I32
3379 S_list_assignment(pTHX_ register OP *o)
3380 {
3381     if (!o)
3382         return TRUE;
3383
3384     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3385         o = cUNOPo->op_first;
3386
3387     if (o->op_type == OP_COND_EXPR) {
3388         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3389         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3390
3391         if (t && f)
3392             return TRUE;
3393         if (t || f)
3394             yyerror("Assignment to both a list and a scalar");
3395         return FALSE;
3396     }
3397
3398     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3399         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3400         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3401         return TRUE;
3402
3403     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3404         return TRUE;
3405
3406     if (o->op_type == OP_RV2SV)
3407         return FALSE;
3408
3409     return FALSE;
3410 }
3411
3412 OP *
3413 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3414 {
3415     OP *o;
3416
3417     if (optype) {
3418         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3419             return newLOGOP(optype, 0,
3420                 mod(scalar(left), optype),
3421                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3422         }
3423         else {
3424             return newBINOP(optype, OPf_STACKED,
3425                 mod(scalar(left), optype), scalar(right));
3426         }
3427     }
3428
3429     if (list_assignment(left)) {
3430         OP *curop;
3431
3432         PL_modcount = 0;
3433         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3434         left = mod(left, OP_AASSIGN);
3435         if (PL_eval_start)
3436             PL_eval_start = 0;
3437         else {
3438             op_free(left);
3439             op_free(right);
3440             return Nullop;
3441         }
3442         curop = list(force_list(left));
3443         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3444         o->op_private = 0 | (flags >> 8);
3445         for (curop = ((LISTOP*)curop)->op_first;
3446              curop; curop = curop->op_sibling)
3447         {
3448             if (curop->op_type == OP_RV2HV &&
3449                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3450                 o->op_private |= OPpASSIGN_HASH;
3451                 break;
3452             }
3453         }
3454         if (!(left->op_private & OPpLVAL_INTRO)) {
3455             OP *lastop = o;
3456             PL_generation++;
3457             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3458                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3459                     if (curop->op_type == OP_GV) {
3460                         GV *gv = cGVOPx_gv(curop);
3461                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3462                             break;
3463                         SvCUR(gv) = PL_generation;
3464                     }
3465                     else if (curop->op_type == OP_PADSV ||
3466                              curop->op_type == OP_PADAV ||
3467                              curop->op_type == OP_PADHV ||
3468                              curop->op_type == OP_PADANY) {
3469                         SV **svp = AvARRAY(PL_comppad_name);
3470                         SV *sv = svp[curop->op_targ];
3471                         if (SvCUR(sv) == PL_generation)
3472                             break;
3473                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3474                     }
3475                     else if (curop->op_type == OP_RV2CV)
3476                         break;
3477                     else if (curop->op_type == OP_RV2SV ||
3478                              curop->op_type == OP_RV2AV ||
3479                              curop->op_type == OP_RV2HV ||
3480                              curop->op_type == OP_RV2GV) {
3481                         if (lastop->op_type != OP_GV)   /* funny deref? */
3482                             break;
3483                     }
3484                     else if (curop->op_type == OP_PUSHRE) {
3485                         if (((PMOP*)curop)->op_pmreplroot) {
3486 #ifdef USE_ITHREADS
3487                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3488 #else
3489                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3490 #endif
3491                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3492                                 break;
3493                             SvCUR(gv) = PL_generation;
3494                         }       
3495                     }
3496                     else
3497                         break;
3498                 }
3499                 lastop = curop;
3500             }
3501             if (curop != o)
3502                 o->op_private |= OPpASSIGN_COMMON;
3503         }
3504         if (right && right->op_type == OP_SPLIT) {
3505             OP* tmpop;
3506             if ((tmpop = ((LISTOP*)right)->op_first) &&
3507                 tmpop->op_type == OP_PUSHRE)
3508             {
3509                 PMOP *pm = (PMOP*)tmpop;
3510                 if (left->op_type == OP_RV2AV &&
3511                     !(left->op_private & OPpLVAL_INTRO) &&
3512                     !(o->op_private & OPpASSIGN_COMMON) )
3513                 {
3514                     tmpop = ((UNOP*)left)->op_first;
3515                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3516 #ifdef USE_ITHREADS
3517                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3518                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3519 #else
3520                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3521                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3522 #endif
3523                         pm->op_pmflags |= PMf_ONCE;
3524                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3525                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3526                         tmpop->op_sibling = Nullop;     /* don't free split */
3527                         right->op_next = tmpop->op_next;  /* fix starting loc */
3528                         op_free(o);                     /* blow off assign */
3529                         right->op_flags &= ~OPf_WANT;
3530                                 /* "I don't know and I don't care." */
3531                         return right;
3532                     }
3533                 }
3534                 else {
3535                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3536                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3537                     {
3538                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3539                         if (SvIVX(sv) == 0)
3540                             sv_setiv(sv, PL_modcount+1);
3541                     }
3542                 }
3543             }
3544         }
3545         return o;
3546     }
3547     if (!right)
3548         right = newOP(OP_UNDEF, 0);
3549     if (right->op_type == OP_READLINE) {
3550         right->op_flags |= OPf_STACKED;
3551         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3552     }
3553     else {
3554         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3555         o = newBINOP(OP_SASSIGN, flags,
3556             scalar(right), mod(scalar(left), OP_SASSIGN) );
3557         if (PL_eval_start)
3558             PL_eval_start = 0;
3559         else {
3560             op_free(o);
3561             return Nullop;
3562         }
3563     }
3564     return o;
3565 }
3566
3567 OP *
3568 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3569 {
3570     U32 seq = intro_my();
3571     register COP *cop;
3572
3573     NewOp(1101, cop, 1, COP);
3574     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3575         cop->op_type = OP_DBSTATE;
3576         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3577     }
3578     else {
3579         cop->op_type = OP_NEXTSTATE;
3580         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3581     }
3582     cop->op_flags = flags;
3583     cop->op_private = (PL_hints & HINT_BYTE);
3584 #ifdef NATIVE_HINTS
3585     cop->op_private |= NATIVE_HINTS;
3586 #endif
3587     PL_compiling.op_private = cop->op_private;
3588     cop->op_next = (OP*)cop;
3589
3590     if (label) {
3591         cop->cop_label = label;
3592         PL_hints |= HINT_BLOCK_SCOPE;
3593     }
3594     cop->cop_seq = seq;
3595     cop->cop_arybase = PL_curcop->cop_arybase;
3596     if (specialWARN(PL_curcop->cop_warnings))
3597         cop->cop_warnings = PL_curcop->cop_warnings ;
3598     else
3599         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3600     if (specialCopIO(PL_curcop->cop_io))
3601         cop->cop_io = PL_curcop->cop_io;
3602     else
3603         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3604
3605
3606     if (PL_copline == NOLINE)
3607         CopLINE_set(cop, CopLINE(PL_curcop));
3608     else {
3609         CopLINE_set(cop, PL_copline);
3610         PL_copline = NOLINE;
3611     }
3612 #ifdef USE_ITHREADS
3613     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3614 #else
3615     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3616 #endif
3617     CopSTASH_set(cop, PL_curstash);
3618
3619     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3620         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3621         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3622             (void)SvIOK_on(*svp);
3623             SvIVX(*svp) = PTR2IV(cop);
3624         }
3625     }
3626
3627     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3628 }
3629
3630 /* "Introduce" my variables to visible status. */
3631 U32
3632 Perl_intro_my(pTHX)
3633 {
3634     SV **svp;
3635     SV *sv;
3636     I32 i;
3637
3638     if (! PL_min_intro_pending)
3639         return PL_cop_seqmax;
3640
3641     svp = AvARRAY(PL_comppad_name);
3642     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3643         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3644             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3645             SvNVX(sv) = (NV)PL_cop_seqmax;
3646         }
3647     }
3648     PL_min_intro_pending = 0;
3649     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3650     return PL_cop_seqmax++;
3651 }
3652
3653 OP *
3654 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3655 {
3656     return new_logop(type, flags, &first, &other);
3657 }
3658
3659 STATIC OP *
3660 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3661 {
3662     LOGOP *logop;
3663     OP *o;
3664     OP *first = *firstp;
3665     OP *other = *otherp;
3666
3667     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3668         return newBINOP(type, flags, scalar(first), scalar(other));
3669
3670     scalarboolean(first);
3671     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3672     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3673         if (type == OP_AND || type == OP_OR) {
3674             if (type == OP_AND)
3675                 type = OP_OR;
3676             else
3677                 type = OP_AND;
3678             o = first;
3679             first = *firstp = cUNOPo->op_first;
3680             if (o->op_next)
3681                 first->op_next = o->op_next;
3682             cUNOPo->op_first = Nullop;
3683             op_free(o);
3684         }
3685     }
3686     if (first->op_type == OP_CONST) {
3687         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3688             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3689         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3690             op_free(first);
3691             *firstp = Nullop;
3692             return other;
3693         }
3694         else {
3695             op_free(other);
3696             *otherp = Nullop;
3697             return first;
3698         }
3699     }
3700     else if (first->op_type == OP_WANTARRAY) {
3701         if (type == OP_AND)
3702             list(other);
3703         else
3704             scalar(other);
3705     }
3706     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3707         OP *k1 = ((UNOP*)first)->op_first;
3708         OP *k2 = k1->op_sibling;
3709         OPCODE warnop = 0;
3710         switch (first->op_type)
3711         {
3712         case OP_NULL:
3713             if (k2 && k2->op_type == OP_READLINE
3714                   && (k2->op_flags & OPf_STACKED)
3715                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3716             {
3717                 warnop = k2->op_type;
3718             }
3719             break;
3720
3721         case OP_SASSIGN:
3722             if (k1->op_type == OP_READDIR
3723                   || k1->op_type == OP_GLOB
3724                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3725                   || k1->op_type == OP_EACH)
3726             {
3727                 warnop = ((k1->op_type == OP_NULL)
3728                           ? k1->op_targ : k1->op_type);
3729             }
3730             break;
3731         }
3732         if (warnop) {
3733             line_t oldline = CopLINE(PL_curcop);
3734             CopLINE_set(PL_curcop, PL_copline);
3735             Perl_warner(aTHX_ WARN_MISC,
3736                  "Value of %s%s can be \"0\"; test with defined()",
3737                  PL_op_desc[warnop],
3738                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3739                   ? " construct" : "() operator"));
3740             CopLINE_set(PL_curcop, oldline);
3741         }
3742     }
3743
3744     if (!other)
3745         return first;
3746
3747     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3748         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3749
3750     NewOp(1101, logop, 1, LOGOP);
3751
3752     logop->op_type = type;
3753     logop->op_ppaddr = PL_ppaddr[type];
3754     logop->op_first = first;
3755     logop->op_flags = flags | OPf_KIDS;
3756     logop->op_other = LINKLIST(other);
3757     logop->op_private = 1 | (flags >> 8);
3758
3759     /* establish postfix order */
3760     logop->op_next = LINKLIST(first);
3761     first->op_next = (OP*)logop;
3762     first->op_sibling = other;
3763
3764     o = newUNOP(OP_NULL, 0, (OP*)logop);
3765     other->op_next = o;
3766
3767     return o;
3768 }
3769
3770 OP *
3771 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3772 {
3773     LOGOP *logop;
3774     OP *start;
3775     OP *o;
3776
3777     if (!falseop)
3778         return newLOGOP(OP_AND, 0, first, trueop);
3779     if (!trueop)
3780         return newLOGOP(OP_OR, 0, first, falseop);
3781
3782     scalarboolean(first);
3783     if (first->op_type == OP_CONST) {
3784         if (SvTRUE(((SVOP*)first)->op_sv)) {
3785             op_free(first);
3786             op_free(falseop);
3787             return trueop;
3788         }
3789         else {
3790             op_free(first);
3791             op_free(trueop);
3792             return falseop;
3793         }
3794     }
3795     else if (first->op_type == OP_WANTARRAY) {
3796         list(trueop);
3797         scalar(falseop);
3798     }
3799     NewOp(1101, logop, 1, LOGOP);
3800     logop->op_type = OP_COND_EXPR;
3801     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3802     logop->op_first = first;
3803     logop->op_flags = flags | OPf_KIDS;
3804     logop->op_private = 1 | (flags >> 8);
3805     logop->op_other = LINKLIST(trueop);
3806     logop->op_next = LINKLIST(falseop);
3807
3808
3809     /* establish postfix order */
3810     start = LINKLIST(first);
3811     first->op_next = (OP*)logop;
3812
3813     first->op_sibling = trueop;
3814     trueop->op_sibling = falseop;
3815     o = newUNOP(OP_NULL, 0, (OP*)logop);
3816
3817     trueop->op_next = falseop->op_next = o;
3818
3819     o->op_next = start;
3820     return o;
3821 }
3822
3823 OP *
3824 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3825 {
3826     LOGOP *range;
3827     OP *flip;
3828     OP *flop;
3829     OP *leftstart;
3830     OP *o;
3831
3832     NewOp(1101, range, 1, LOGOP);
3833
3834     range->op_type = OP_RANGE;
3835     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3836     range->op_first = left;
3837     range->op_flags = OPf_KIDS;
3838     leftstart = LINKLIST(left);
3839     range->op_other = LINKLIST(right);
3840     range->op_private = 1 | (flags >> 8);
3841
3842     left->op_sibling = right;
3843
3844     range->op_next = (OP*)range;
3845     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3846     flop = newUNOP(OP_FLOP, 0, flip);
3847     o = newUNOP(OP_NULL, 0, flop);
3848     linklist(flop);
3849     range->op_next = leftstart;
3850
3851     left->op_next = flip;
3852     right->op_next = flop;
3853
3854     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3855     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3856     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3857     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3858
3859     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3860     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3861
3862     flip->op_next = o;
3863     if (!flip->op_private || !flop->op_private)
3864         linklist(o);            /* blow off optimizer unless constant */
3865
3866     return o;
3867 }
3868
3869 OP *
3870 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3871 {
3872     OP* listop;
3873     OP* o;
3874     int once = block && block->op_flags & OPf_SPECIAL &&
3875       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3876
3877     if (expr) {
3878         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3879             return block;       /* do {} while 0 does once */
3880         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3881             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3882             expr = newUNOP(OP_DEFINED, 0,
3883                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3884         } else if (expr->op_flags & OPf_KIDS) {
3885             OP *k1 = ((UNOP*)expr)->op_first;
3886             OP *k2 = (k1) ? k1->op_sibling : NULL;
3887             switch (expr->op_type) {
3888               case OP_NULL:
3889                 if (k2 && k2->op_type == OP_READLINE
3890                       && (k2->op_flags & OPf_STACKED)
3891                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3892                     expr = newUNOP(OP_DEFINED, 0, expr);
3893                 break;
3894
3895               case OP_SASSIGN:
3896                 if (k1->op_type == OP_READDIR
3897                       || k1->op_type == OP_GLOB
3898                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3899                       || k1->op_type == OP_EACH)
3900                     expr = newUNOP(OP_DEFINED, 0, expr);
3901                 break;
3902             }
3903         }
3904     }
3905
3906     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3907     o = new_logop(OP_AND, 0, &expr, &listop);
3908
3909     if (listop)
3910         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3911
3912     if (once && o != listop)
3913         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3914
3915     if (o == listop)
3916         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3917
3918     o->op_flags |= flags;
3919     o = scope(o);
3920     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3921     return o;
3922 }
3923
3924 OP *
3925 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3926 {
3927     OP *redo;
3928     OP *next = 0;
3929     OP *listop;
3930     OP *o;
3931     OP *condop;
3932     U8 loopflags = 0;
3933
3934     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3935                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3936         expr = newUNOP(OP_DEFINED, 0,
3937             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3938     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3939         OP *k1 = ((UNOP*)expr)->op_first;
3940         OP *k2 = (k1) ? k1->op_sibling : NULL;
3941         switch (expr->op_type) {
3942           case OP_NULL:
3943             if (k2 && k2->op_type == OP_READLINE
3944                   && (k2->op_flags & OPf_STACKED)
3945                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3946                 expr = newUNOP(OP_DEFINED, 0, expr);
3947             break;
3948
3949           case OP_SASSIGN:
3950             if (k1->op_type == OP_READDIR
3951                   || k1->op_type == OP_GLOB
3952                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3953                   || k1->op_type == OP_EACH)
3954                 expr = newUNOP(OP_DEFINED, 0, expr);
3955             break;
3956         }
3957     }
3958
3959     if (!block)
3960         block = newOP(OP_NULL, 0);
3961     else if (cont) {
3962         block = scope(block);
3963     }
3964
3965     if (cont) {
3966         next = LINKLIST(cont);
3967     }
3968     if (expr) {
3969         OP *unstack = newOP(OP_UNSTACK, 0);
3970         if (!next)
3971             next = unstack;
3972         cont = append_elem(OP_LINESEQ, cont, unstack);
3973         if ((line_t)whileline != NOLINE) {
3974             PL_copline = whileline;
3975             cont = append_elem(OP_LINESEQ, cont,
3976                                newSTATEOP(0, Nullch, Nullop));
3977         }
3978     }
3979
3980     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3981     redo = LINKLIST(listop);
3982
3983     if (expr) {
3984         PL_copline = whileline;
3985         scalar(listop);
3986         o = new_logop(OP_AND, 0, &expr, &listop);
3987         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3988             op_free(expr);              /* oops, it's a while (0) */
3989             op_free((OP*)loop);
3990             return Nullop;              /* listop already freed by new_logop */
3991         }
3992         if (listop)
3993             ((LISTOP*)listop)->op_last->op_next = condop =
3994                 (o == listop ? redo : LINKLIST(o));
3995     }
3996     else
3997         o = listop;
3998
3999     if (!loop) {
4000         NewOp(1101,loop,1,LOOP);
4001         loop->op_type = OP_ENTERLOOP;
4002         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4003         loop->op_private = 0;
4004         loop->op_next = (OP*)loop;
4005     }
4006
4007     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4008
4009     loop->op_redoop = redo;
4010     loop->op_lastop = o;
4011     o->op_private |= loopflags;
4012
4013     if (next)
4014         loop->op_nextop = next;
4015     else
4016         loop->op_nextop = o;
4017
4018     o->op_flags |= flags;
4019     o->op_private |= (flags >> 8);
4020     return o;
4021 }
4022
4023 OP *
4024 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4025 {
4026     LOOP *loop;
4027     OP *wop;
4028     int padoff = 0;
4029     I32 iterflags = 0;
4030
4031     if (sv) {
4032         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4033             sv->op_type = OP_RV2GV;
4034             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4035         }
4036         else if (sv->op_type == OP_PADSV) { /* private variable */
4037             padoff = sv->op_targ;
4038             sv->op_targ = 0;
4039             op_free(sv);
4040             sv = Nullop;
4041         }
4042         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4043             padoff = sv->op_targ;
4044             sv->op_targ = 0;
4045             iterflags |= OPf_SPECIAL;
4046             op_free(sv);
4047             sv = Nullop;
4048         }
4049         else
4050             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4051     }
4052     else {
4053 #ifdef USE_THREADS
4054         padoff = find_threadsv("_");
4055         iterflags |= OPf_SPECIAL;
4056 #else
4057         sv = newGVOP(OP_GV, 0, PL_defgv);
4058 #endif
4059     }
4060     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4061         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4062         iterflags |= OPf_STACKED;
4063     }
4064     else if (expr->op_type == OP_NULL &&
4065              (expr->op_flags & OPf_KIDS) &&
4066              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4067     {
4068         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4069          * set the STACKED flag to indicate that these values are to be
4070          * treated as min/max values by 'pp_iterinit'.
4071          */
4072         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4073         LOGOP* range = (LOGOP*) flip->op_first;
4074         OP* left  = range->op_first;
4075         OP* right = left->op_sibling;
4076         LISTOP* listop;
4077
4078         range->op_flags &= ~OPf_KIDS;
4079         range->op_first = Nullop;
4080
4081         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4082         listop->op_first->op_next = range->op_next;
4083         left->op_next = range->op_other;
4084         right->op_next = (OP*)listop;
4085         listop->op_next = listop->op_first;
4086
4087         op_free(expr);
4088         expr = (OP*)(listop);
4089         null(expr);
4090         iterflags |= OPf_STACKED;
4091     }
4092     else {
4093         expr = mod(force_list(expr), OP_GREPSTART);
4094     }
4095
4096
4097     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4098                                append_elem(OP_LIST, expr, scalar(sv))));
4099     assert(!loop->op_next);
4100 #ifdef PL_OP_SLAB_ALLOC
4101     {
4102         LOOP *tmp;
4103         NewOp(1234,tmp,1,LOOP);
4104         Copy(loop,tmp,1,LOOP);
4105         loop = tmp;
4106     }
4107 #else
4108     Renew(loop, 1, LOOP);
4109 #endif
4110     loop->op_targ = padoff;
4111     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4112     PL_copline = forline;
4113     return newSTATEOP(0, label, wop);
4114 }
4115
4116 OP*
4117 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4118 {
4119     OP *o;
4120     STRLEN n_a;
4121
4122     if (type != OP_GOTO || label->op_type == OP_CONST) {
4123         /* "last()" means "last" */
4124         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4125             o = newOP(type, OPf_SPECIAL);
4126         else {
4127             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4128                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4129                                         : ""));
4130         }
4131         op_free(label);
4132     }
4133     else {
4134         if (label->op_type == OP_ENTERSUB)
4135             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4136         o = newUNOP(type, OPf_STACKED, label);
4137     }
4138     PL_hints |= HINT_BLOCK_SCOPE;
4139     return o;
4140 }
4141
4142 void
4143 Perl_cv_undef(pTHX_ CV *cv)
4144 {
4145 #ifdef USE_THREADS
4146     if (CvMUTEXP(cv)) {
4147         MUTEX_DESTROY(CvMUTEXP(cv));
4148         Safefree(CvMUTEXP(cv));
4149         CvMUTEXP(cv) = 0;
4150     }
4151 #endif /* USE_THREADS */
4152
4153     if (!CvXSUB(cv) && CvROOT(cv)) {
4154 #ifdef USE_THREADS
4155         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4156             Perl_croak(aTHX_ "Can't undef active subroutine");
4157 #else
4158         if (CvDEPTH(cv))
4159             Perl_croak(aTHX_ "Can't undef active subroutine");
4160 #endif /* USE_THREADS */
4161         ENTER;
4162
4163         SAVEVPTR(PL_curpad);
4164         PL_curpad = 0;
4165
4166         op_free(CvROOT(cv));
4167         CvROOT(cv) = Nullop;
4168         LEAVE;
4169     }
4170     SvPOK_off((SV*)cv);         /* forget prototype */
4171     CvGV(cv) = Nullgv;
4172     /* Since closure prototypes have the same lifetime as the containing
4173      * CV, they don't hold a refcount on the outside CV.  This avoids
4174      * the refcount loop between the outer CV (which keeps a refcount to
4175      * the closure prototype in the pad entry for pp_anoncode()) and the
4176      * closure prototype, and the ensuing memory leak.  --GSAR */
4177     if (!CvANON(cv) || CvCLONED(cv))
4178         SvREFCNT_dec(CvOUTSIDE(cv));
4179     CvOUTSIDE(cv) = Nullcv;
4180     if (CvCONST(cv)) {
4181         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4182         CvCONST_off(cv);
4183     }
4184     if (CvPADLIST(cv)) {
4185         /* may be during global destruction */
4186         if (SvREFCNT(CvPADLIST(cv))) {
4187             I32 i = AvFILLp(CvPADLIST(cv));
4188             while (i >= 0) {
4189                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4190                 SV* sv = svp ? *svp : Nullsv;
4191                 if (!sv)
4192                     continue;
4193                 if (sv == (SV*)PL_comppad_name)
4194                     PL_comppad_name = Nullav;
4195                 else if (sv == (SV*)PL_comppad) {
4196                     PL_comppad = Nullav;
4197                     PL_curpad = Null(SV**);
4198                 }
4199                 SvREFCNT_dec(sv);
4200             }
4201             SvREFCNT_dec((SV*)CvPADLIST(cv));
4202         }
4203         CvPADLIST(cv) = Nullav;
4204     }
4205     CvFLAGS(cv) = 0;
4206 }
4207
4208 #ifdef DEBUG_CLOSURES
4209 STATIC void
4210 S_cv_dump(pTHX_ CV *cv)
4211 {
4212 #ifdef DEBUGGING
4213     CV *outside = CvOUTSIDE(cv);
4214     AV* padlist = CvPADLIST(cv);
4215     AV* pad_name;
4216     AV* pad;
4217     SV** pname;
4218     SV** ppad;
4219     I32 ix;
4220
4221     PerlIO_printf(Perl_debug_log,
4222                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4223                   PTR2UV(cv),
4224                   (CvANON(cv) ? "ANON"
4225                    : (cv == PL_main_cv) ? "MAIN"
4226                    : CvUNIQUE(cv) ? "UNIQUE"
4227                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4228                   PTR2UV(outside),
4229                   (!outside ? "null"
4230                    : CvANON(outside) ? "ANON"
4231                    : (outside == PL_main_cv) ? "MAIN"
4232                    : CvUNIQUE(outside) ? "UNIQUE"
4233                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4234
4235     if (!padlist)
4236         return;
4237
4238     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4239     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4240     pname = AvARRAY(pad_name);
4241     ppad = AvARRAY(pad);
4242
4243     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4244         if (SvPOK(pname[ix]))
4245             PerlIO_printf(Perl_debug_log,
4246                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4247                           (int)ix, PTR2UV(ppad[ix]),
4248                           SvFAKE(pname[ix]) ? "FAKE " : "",
4249                           SvPVX(pname[ix]),
4250                           (IV)I_32(SvNVX(pname[ix])),
4251                           SvIVX(pname[ix]));
4252     }
4253 #endif /* DEBUGGING */
4254 }
4255 #endif /* DEBUG_CLOSURES */
4256
4257 STATIC CV *
4258 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4259 {
4260     AV* av;
4261     I32 ix;
4262     AV* protopadlist = CvPADLIST(proto);
4263     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4264     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4265     SV** pname = AvARRAY(protopad_name);
4266     SV** ppad = AvARRAY(protopad);
4267     I32 fname = AvFILLp(protopad_name);
4268     I32 fpad = AvFILLp(protopad);
4269     AV* comppadlist;
4270     CV* cv;
4271
4272     assert(!CvUNIQUE(proto));
4273
4274     ENTER;
4275     SAVECOMPPAD();
4276     SAVESPTR(PL_comppad_name);
4277     SAVESPTR(PL_compcv);
4278
4279     cv = PL_compcv = (CV*)NEWSV(1104,0);
4280     sv_upgrade((SV *)cv, SvTYPE(proto));
4281     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4282     CvCLONED_on(cv);
4283
4284 #ifdef USE_THREADS
4285     New(666, CvMUTEXP(cv), 1, perl_mutex);
4286     MUTEX_INIT(CvMUTEXP(cv));
4287     CvOWNER(cv)         = 0;
4288 #endif /* USE_THREADS */
4289     CvFILE(cv)          = CvFILE(proto);
4290     CvGV(cv)            = CvGV(proto);
4291     CvSTASH(cv)         = CvSTASH(proto);
4292     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4293     CvSTART(cv)         = CvSTART(proto);
4294     if (outside)
4295         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4296
4297     if (SvPOK(proto))
4298         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4299
4300     PL_comppad_name = newAV();
4301     for (ix = fname; ix >= 0; ix--)
4302         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4303
4304     PL_comppad = newAV();
4305
4306     comppadlist = newAV();
4307     AvREAL_off(comppadlist);
4308     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4309     av_store(comppadlist, 1, (SV*)PL_comppad);
4310     CvPADLIST(cv) = comppadlist;
4311     av_fill(PL_comppad, AvFILLp(protopad));
4312     PL_curpad = AvARRAY(PL_comppad);
4313
4314     av = newAV();           /* will be @_ */
4315     av_extend(av, 0);
4316     av_store(PL_comppad, 0, (SV*)av);
4317     AvFLAGS(av) = AVf_REIFY;
4318
4319     for (ix = fpad; ix > 0; ix--) {
4320         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4321         if (namesv && namesv != &PL_sv_undef) {
4322             char *name = SvPVX(namesv);    /* XXX */
4323             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4324                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4325                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4326                 if (!off)
4327                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4328                 else if (off != ix)
4329                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4330             }
4331             else {                              /* our own lexical */
4332                 SV* sv;
4333                 if (*name == '&') {
4334                     /* anon code -- we'll come back for it */
4335                     sv = SvREFCNT_inc(ppad[ix]);
4336                 }
4337                 else if (*name == '@')
4338                     sv = (SV*)newAV();
4339                 else if (*name == '%')
4340                     sv = (SV*)newHV();
4341                 else
4342                     sv = NEWSV(0,0);
4343                 if (!SvPADBUSY(sv))
4344                     SvPADMY_on(sv);
4345                 PL_curpad[ix] = sv;
4346             }
4347         }
4348         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4349             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4350         }
4351         else {
4352             SV* sv = NEWSV(0,0);
4353             SvPADTMP_on(sv);
4354             PL_curpad[ix] = sv;
4355         }
4356     }
4357
4358     /* Now that vars are all in place, clone nested closures. */
4359
4360     for (ix = fpad; ix > 0; ix--) {
4361         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4362         if (namesv
4363             && namesv != &PL_sv_undef
4364             && !(SvFLAGS(namesv) & SVf_FAKE)
4365             && *SvPVX(namesv) == '&'
4366             && CvCLONE(ppad[ix]))
4367         {
4368             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4369             SvREFCNT_dec(ppad[ix]);
4370             CvCLONE_on(kid);
4371             SvPADMY_on(kid);
4372             PL_curpad[ix] = (SV*)kid;
4373         }
4374     }
4375
4376 #ifdef DEBUG_CLOSURES
4377     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4378     cv_dump(outside);
4379     PerlIO_printf(Perl_debug_log, "  from:\n");
4380     cv_dump(proto);
4381     PerlIO_printf(Perl_debug_log, "   to:\n");
4382     cv_dump(cv);
4383 #endif
4384
4385     LEAVE;
4386
4387     if (CvCONST(cv)) {
4388         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4389         assert(const_sv);
4390         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4391         SvREFCNT_dec(cv);
4392         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4393     }
4394
4395     return cv;
4396 }
4397
4398 CV *
4399 Perl_cv_clone(pTHX_ CV *proto)
4400 {
4401     CV *cv;
4402     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4403     cv = cv_clone2(proto, CvOUTSIDE(proto));
4404     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4405     return cv;
4406 }
4407
4408 void
4409 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4410 {
4411     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4412         SV* msg = sv_newmortal();
4413         SV* name = Nullsv;
4414
4415         if (gv)
4416             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4417         sv_setpv(msg, "Prototype mismatch:");
4418         if (name)
4419             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4420         if (SvPOK(cv))
4421             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4422         sv_catpv(msg, " vs ");
4423         if (p)
4424             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4425         else
4426             sv_catpv(msg, "none");
4427         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4428     }
4429 }
4430
4431 static void const_sv_xsub(pTHXo_ CV* cv);
4432
4433 /*
4434 =for apidoc cv_const_sv
4435
4436 If C<cv> is a constant sub eligible for inlining. returns the constant
4437 value returned by the sub.  Otherwise, returns NULL.
4438
4439 Constant subs can be created with C<newCONSTSUB> or as described in
4440 L<perlsub/"Constant Functions">.
4441
4442 =cut
4443 */
4444 SV *
4445 Perl_cv_const_sv(pTHX_ CV *cv)
4446 {
4447     if (!cv || !CvCONST(cv))
4448         return Nullsv;
4449     return (SV*)CvXSUBANY(cv).any_ptr;
4450 }
4451
4452 SV *
4453 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4454 {
4455     SV *sv = Nullsv;
4456
4457     if (!o)
4458         return Nullsv;
4459
4460     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4461         o = cLISTOPo->op_first->op_sibling;
4462
4463     for (; o; o = o->op_next) {
4464         OPCODE type = o->op_type;
4465
4466         if (sv && o->op_next == o)
4467             return sv;
4468         if (o->op_next != o) {
4469             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4470                 continue;
4471             if (type == OP_DBSTATE)
4472                 continue;
4473         }
4474         if (type == OP_LEAVESUB || type == OP_RETURN)
4475             break;
4476         if (sv)
4477             return Nullsv;
4478         if (type == OP_CONST && cSVOPo->op_sv)
4479             sv = cSVOPo->op_sv;
4480         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4481             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4482             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4483             if (!sv)
4484                 return Nullsv;
4485             if (CvCONST(cv)) {
4486                 /* We get here only from cv_clone2() while creating a closure.
4487                    Copy the const value here instead of in cv_clone2 so that
4488                    SvREADONLY_on doesn't lead to problems when leaving
4489                    scope.
4490                 */
4491                 sv = newSVsv(sv);
4492             }
4493             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4494                 return Nullsv;
4495         }
4496         else
4497             return Nullsv;
4498     }
4499     if (sv)
4500         SvREADONLY_on(sv);
4501     return sv;
4502 }
4503
4504 void
4505 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4506 {
4507     if (o)
4508         SAVEFREEOP(o);
4509     if (proto)
4510         SAVEFREEOP(proto);
4511     if (attrs)
4512         SAVEFREEOP(attrs);
4513     if (block)
4514         SAVEFREEOP(block);
4515     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4516 }
4517
4518 CV *
4519 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4520 {
4521     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4522 }
4523
4524 CV *
4525 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4526 {
4527     STRLEN n_a;
4528     char *name;
4529     char *aname;
4530     GV *gv;
4531     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4532     register CV *cv=0;
4533     I32 ix;
4534     SV *const_sv;
4535
4536     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4537     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4538         SV *sv = sv_newmortal();
4539         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4540                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4541         aname = SvPVX(sv);
4542     }
4543     else
4544         aname = Nullch;
4545     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4546                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4547                     SVt_PVCV);
4548
4549     if (o)
4550         SAVEFREEOP(o);
4551     if (proto)
4552         SAVEFREEOP(proto);
4553     if (attrs)
4554         SAVEFREEOP(attrs);
4555
4556     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4557                                            maximum a prototype before. */
4558         if (SvTYPE(gv) > SVt_NULL) {
4559             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4560                 && ckWARN_d(WARN_PROTOTYPE))
4561             {
4562                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4563             }
4564             cv_ckproto((CV*)gv, NULL, ps);
4565         }
4566         if (ps)
4567             sv_setpv((SV*)gv, ps);
4568         else
4569             sv_setiv((SV*)gv, -1);
4570         SvREFCNT_dec(PL_compcv);
4571         cv = PL_compcv = NULL;
4572         PL_sub_generation++;
4573         goto done;
4574     }
4575
4576     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4577
4578 #ifdef GV_SHARED_CHECK
4579     if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4580         Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4581     }
4582 #endif
4583
4584     if (!block || !ps || *ps || attrs)
4585         const_sv = Nullsv;
4586     else
4587         const_sv = op_const_sv(block, Nullcv);
4588
4589     if (cv) {
4590         bool exists = CvROOT(cv) || CvXSUB(cv);
4591
4592 #ifdef GV_SHARED_CHECK
4593         if (exists && GvSHARED(gv)) {
4594             Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4595         }
4596 #endif
4597
4598         /* if the subroutine doesn't exist and wasn't pre-declared
4599          * with a prototype, assume it will be AUTOLOADed,
4600          * skipping the prototype check
4601          */
4602         if (exists || SvPOK(cv))
4603             cv_ckproto(cv, gv, ps);
4604         /* already defined (or promised)? */
4605         if (exists || GvASSUMECV(gv)) {
4606             if (!block && !attrs) {
4607                 /* just a "sub foo;" when &foo is already defined */
4608                 SAVEFREESV(PL_compcv);
4609                 goto done;
4610             }
4611             /* ahem, death to those who redefine active sort subs */
4612             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4613                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4614             if (block) {
4615                 if (ckWARN(WARN_REDEFINE)
4616                     || (CvCONST(cv)
4617                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4618                 {
4619                     line_t oldline = CopLINE(PL_curcop);
4620                     CopLINE_set(PL_curcop, PL_copline);
4621                     Perl_warner(aTHX_ WARN_REDEFINE,
4622                         CvCONST(cv) ? "Constant subroutine %s redefined"
4623                                     : "Subroutine %s redefined", name);
4624                     CopLINE_set(PL_curcop, oldline);
4625                 }
4626                 SvREFCNT_dec(cv);
4627                 cv = Nullcv;
4628             }
4629         }
4630     }
4631     if (const_sv) {
4632         SvREFCNT_inc(const_sv);
4633         if (cv) {
4634             assert(!CvROOT(cv) && !CvCONST(cv));
4635             sv_setpv((SV*)cv, "");  /* prototype is "" */
4636             CvXSUBANY(cv).any_ptr = const_sv;
4637             CvXSUB(cv) = const_sv_xsub;
4638             CvCONST_on(cv);
4639         }
4640         else {
4641             GvCV(gv) = Nullcv;
4642             cv = newCONSTSUB(NULL, name, const_sv);
4643         }
4644         op_free(block);
4645         SvREFCNT_dec(PL_compcv);
4646         PL_compcv = NULL;
4647         PL_sub_generation++;
4648         goto done;
4649     }
4650     if (attrs) {
4651         HV *stash;
4652         SV *rcv;
4653
4654         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4655          * before we clobber PL_compcv.
4656          */
4657         if (cv && !block) {
4658             rcv = (SV*)cv;
4659             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4660                 stash = GvSTASH(CvGV(cv));
4661             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4662                 stash = CvSTASH(cv);
4663             else
4664                 stash = PL_curstash;
4665         }
4666         else {
4667             /* possibly about to re-define existing subr -- ignore old cv */
4668             rcv = (SV*)PL_compcv;
4669             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4670                 stash = GvSTASH(gv);
4671             else
4672                 stash = PL_curstash;
4673         }
4674         apply_attrs(stash, rcv, attrs);
4675     }
4676     if (cv) {                           /* must reuse cv if autoloaded */
4677         if (!block) {
4678             /* got here with just attrs -- work done, so bug out */
4679             SAVEFREESV(PL_compcv);
4680             goto done;
4681         }
4682         cv_undef(cv);
4683         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4684         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4685         CvOUTSIDE(PL_compcv) = 0;
4686         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4687         CvPADLIST(PL_compcv) = 0;
4688         /* inner references to PL_compcv must be fixed up ... */
4689         {
4690             AV *padlist = CvPADLIST(cv);
4691             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4692             AV *comppad = (AV*)AvARRAY(padlist)[1];
4693             SV **namepad = AvARRAY(comppad_name);
4694             SV **curpad = AvARRAY(comppad);
4695             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4696                 SV *namesv = namepad[ix];
4697                 if (namesv && namesv != &PL_sv_undef
4698                     && *SvPVX(namesv) == '&')
4699                 {
4700                     CV *innercv = (CV*)curpad[ix];
4701                     if (CvOUTSIDE(innercv) == PL_compcv) {
4702                         CvOUTSIDE(innercv) = cv;
4703                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4704                             (void)SvREFCNT_inc(cv);
4705                             SvREFCNT_dec(PL_compcv);
4706                         }
4707                     }
4708                 }
4709             }
4710         }
4711         /* ... before we throw it away */
4712         SvREFCNT_dec(PL_compcv);
4713     }
4714     else {
4715         cv = PL_compcv;
4716         if (name) {
4717             GvCV(gv) = cv;
4718             GvCVGEN(gv) = 0;
4719             PL_sub_generation++;
4720         }
4721     }
4722     CvGV(cv) = gv;
4723     CvFILE(cv) = CopFILE(PL_curcop);
4724     CvSTASH(cv) = PL_curstash;
4725 #ifdef USE_THREADS
4726     CvOWNER(cv) = 0;
4727     if (!CvMUTEXP(cv)) {
4728         New(666, CvMUTEXP(cv), 1, perl_mutex);
4729         MUTEX_INIT(CvMUTEXP(cv));
4730     }
4731 #endif /* USE_THREADS */
4732
4733     if (ps)
4734         sv_setpv((SV*)cv, ps);
4735
4736     if (PL_error_count) {
4737         op_free(block);
4738         block = Nullop;
4739         if (name) {
4740             char *s = strrchr(name, ':');
4741             s = s ? s+1 : name;
4742             if (strEQ(s, "BEGIN")) {
4743                 char *not_safe =
4744                     "BEGIN not safe after errors--compilation aborted";
4745                 if (PL_in_eval & EVAL_KEEPERR)
4746                     Perl_croak(aTHX_ not_safe);
4747                 else {
4748                     /* force display of errors found but not reported */
4749                     sv_catpv(ERRSV, not_safe);
4750                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4751                 }
4752             }