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