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