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