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