This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PL_curpad == AvARRAY(PL_comppad) always
[perl5.git] / pad.c
1 /*    pad.c
2  *
3  *    Copyright (c) 2002, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  *  "Anyway: there was this Mr Frodo left an orphan and stranded, as you
9  *  might say, among those queer Bucklanders, being brought up anyhow in
10  *  Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
11  *  never had fewer than a couple of hundred relations in the place. Mr
12  *  Bilbo never did a kinder deed than when he brought the lad back to
13  *  live among decent folk." --the Gaffer
14  */
15
16 /* XXX DAPM
17  * As of Sept 2002, this file is new and may be in a state of flux for
18  * a while. I've marked things I intent to come back and look at further
19  * with an 'XXX DAPM' comment.
20  */
21
22 /*
23 =head1 Pad Data Structures
24
25 =for apidoc m|AV *|CvPADLIST|CV *cv
26 CV's can have CvPADLIST(cv) set to point to an AV.
27
28 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
29 not callable at will and are always thrown away after the eval"" is done
30 executing).
31
32 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
33 but that is really the callers pad (a slot of which is allocated by
34 every entersub).
35
36 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
37 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
38 The items in the AV are not SVs as for a normal AV, but other AVs:
39
40 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
41 the "static type information" for lexicals.
42
43 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
44 depth of recursion into the CV.
45 The 0'th slot of a frame AV is an AV which is @_.
46 other entries are storage for variables and op targets.
47
48 During compilation:
49 C<PL_comppad_name> is set the the the names AV.
50 C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
51 C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
52
53 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
54 frame of the currently executing sub.
55
56 Iterating over the names AV iterates over all possible pad
57 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
58 &PL_sv_undef "names" (see pad_alloc()).
59
60 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
61 The rest are op targets/GVs/constants which are statically allocated
62 or resolved at compile time.  These don't have names by which they
63 can be looked up from Perl code at run time through eval"" like
64 my/our variables can be.  Since they can't be looked up by "name"
65 but only by their index allocated at compile time (which is usually
66 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
67
68 The SVs in the names AV have their PV being the name of the variable.
69 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
70 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
71 type.  For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
72 stash of the associated global (so that duplicate C<our> delarations in the
73 same package can be detected).  SvCUR is sometimes hijacked to
74 store the generation number during compilation.
75
76 If SvFAKE is set on the name SV then slot in the frame AVs are
77 a REFCNT'ed references to a lexical from "outside".
78
79 If the 'name' is '&' the the corresponding entry in frame AV
80 is a CV representing a possible closure.
81 (SvFAKE and name of '&' is not a meaningful combination currently but could
82 become so if C<my sub foo {}> is implemented.)
83
84 =cut
85 */
86
87
88 #include "EXTERN.h"
89 #define PERL_IN_PAD_C
90 #include "perl.h"
91
92
93 #define PAD_MAX 999999999
94
95
96
97 /*
98 =for apidoc pad_new
99
100 Create a new compiling padlist, saving and updating the various global
101 vars at the same time as creating the pad itself. The following flags
102 can be OR'ed together:
103
104     padnew_CLONE        this pad is for a cloned CV
105     padnew_SAVE         save old globals
106     padnew_SAVESUB      also save extra stuff for start of sub
107
108 =cut
109 */
110
111 PADLIST *
112 Perl_pad_new(pTHX_ padnew_flags flags)
113 {
114     AV *padlist, *padname, *pad, *a0;
115
116     ASSERT_CURPAD_LEGAL("pad_new");
117
118     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
119      * vars (based on flags) rather than storing vals + addresses for
120      * each individually. Also see pad_block_start.
121      * XXX DAPM Try to see whether all these conditionals are required
122      */
123
124     /* save existing state, ... */
125
126     if (flags & padnew_SAVE) {
127         SAVECOMPPAD();
128         SAVESPTR(PL_comppad_name);
129         if (! (flags & padnew_CLONE)) {
130             SAVEI32(PL_padix);
131             SAVEI32(PL_comppad_name_fill);
132             SAVEI32(PL_min_intro_pending);
133             SAVEI32(PL_max_intro_pending);
134             if (flags & padnew_SAVESUB) {
135                 SAVEI32(PL_pad_reset_pending);
136             }
137         }
138     }
139     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
140      * saved - check at some pt that this is okay */
141
142     /* ... create new pad ... */
143
144     padlist     = newAV();
145     padname     = newAV();
146     pad         = newAV();
147
148     if (flags & padnew_CLONE) {
149         /* XXX DAPM  I dont know why cv_clone needs it
150          * doing differently yet - perhaps this separate branch can be
151          * dispensed with eventually ???
152          */
153
154         a0 = newAV();                   /* will be @_ */
155         av_extend(a0, 0);
156         av_store(pad, 0, (SV*)a0);
157         AvFLAGS(a0) = AVf_REIFY;
158     }
159     else {
160         av_store(pad, 0, Nullsv);
161     }
162
163     AvREAL_off(padlist);
164     av_store(padlist, 0, (SV*)padname);
165     av_store(padlist, 1, (SV*)pad);
166
167     /* ... then update state variables */
168
169     PL_comppad_name     = (AV*)(*av_fetch(padlist, 0, FALSE));
170     PL_comppad          = (AV*)(*av_fetch(padlist, 1, FALSE));
171     PL_curpad           = AvARRAY(PL_comppad);
172
173     if (! (flags & padnew_CLONE)) {
174         PL_comppad_name_fill = 0;
175         PL_min_intro_pending = 0;
176         PL_padix             = 0;
177     }
178
179     DEBUG_X(PerlIO_printf(Perl_debug_log,
180           "Pad 0x%"UVxf"[0x%"UVxf"] new:       padlist=0x%"UVxf
181               " name=0x%"UVxf" flags=0x%"UVxf"\n",
182           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
183               PTR2UV(padname), (UV)flags
184         )
185     );
186
187     return (PADLIST*)padlist;
188 }
189
190 /*
191 =for apidoc pad_undef
192
193 Free the padlist associated with a CV.
194 If parts of it happen to be current, we null the relevant
195 PL_*pad* global vars so that we don't have any dangling references left.
196 We also repoint the CvOUTSIDE of any about-to-be-orphaned
197 inner subs to outercv.
198
199 =cut
200 */
201
202 void
203 Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
204 {
205     I32 ix;
206     PADLIST *padlist = CvPADLIST(cv);
207
208     if (!padlist)
209         return;
210     if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
211         return;
212
213     DEBUG_X(PerlIO_printf(Perl_debug_log,
214           "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
215     );
216
217     /* pads may be cleared out already during global destruction */
218     if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
219             && !PL_dirty) || CvSPECIAL(cv))
220     {
221         /* XXX DAPM the following code is very similar to
222          * pad_fixup_inner_anons(). Merge??? */
223
224         /* inner references to eval's cv must be fixed up */
225         AV *comppad_name = (AV*)AvARRAY(padlist)[0];
226         SV **namepad = AvARRAY(comppad_name);
227         AV *comppad = (AV*)AvARRAY(padlist)[1];
228         SV **curpad = AvARRAY(comppad);
229         for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
230             SV *namesv = namepad[ix];
231             if (namesv && namesv != &PL_sv_undef
232                 && *SvPVX(namesv) == '&'
233                 && ix <= AvFILLp(comppad))
234             {
235                 CV *innercv = (CV*)curpad[ix];
236                 if (innercv && SvTYPE(innercv) == SVt_PVCV
237                     && CvOUTSIDE(innercv) == cv)
238                 {
239                     CvOUTSIDE(innercv) = outercv;
240                     if (!CvANON(innercv) || CvCLONED(innercv)) {
241                         (void)SvREFCNT_inc(outercv);
242                         if (SvREFCNT(cv))
243                             SvREFCNT_dec(cv);
244                     }
245                 }
246             }
247         }
248     }
249     ix = AvFILLp(padlist);
250     while (ix >= 0) {
251         SV* sv = AvARRAY(padlist)[ix--];
252         if (!sv)
253             continue;
254         if (sv == (SV*)PL_comppad_name)
255             PL_comppad_name = Nullav;
256         else if (sv == (SV*)PL_comppad) {
257             PL_comppad = Null(PAD*);
258             PL_curpad = Null(SV**);
259         }
260         SvREFCNT_dec(sv);
261     }
262     SvREFCNT_dec((SV*)CvPADLIST(cv));
263     CvPADLIST(cv) = Null(PADLIST*);
264 }
265
266
267
268
269 /*
270 =for apidoc pad_add_name
271
272 Create a new name in the current pad at the specified offset.
273 If C<typestash> is valid, the name is for a typed lexical; set the
274 name's stash to that value.
275 If C<ourstash> is valid, it's an our lexical, set the name's
276 GvSTASH to that value
277
278 Also, if the name is @.. or %.., create a new array or hash for that slot
279
280 If fake, it means we're cloning an existing entry
281
282 =cut
283 */
284
285 /*
286  * XXX DAPM this doesn't seem the right place to create a new array/hash.
287  * Whatever we do, we should be consistent - create scalars too, and
288  * create even if fake. Really need to integrate better the whole entry
289  * creation business - when + where does the name and value get created?
290  */
291
292 PADOFFSET
293 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
294 {
295     PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
296     SV* namesv = NEWSV(1102, 0);
297     U32 min, max;
298
299     ASSERT_CURPAD_ACTIVE("pad_add_name");
300
301     if (fake) {
302         min = PL_curcop->cop_seq;
303         max = PAD_MAX;
304     }
305     else {
306         /* not yet introduced */
307         min = PAD_MAX;
308         max = 0;
309     }
310
311     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
312           "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
313            (long)offset, name, (unsigned long)min, (unsigned long)max,
314           (fake ? " FAKE" : "")
315           )
316     );
317
318     sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
319     sv_setpv(namesv, name);
320
321     if (typestash) {
322         SvFLAGS(namesv) |= SVpad_TYPED;
323         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
324     }
325     if (ourstash) {
326         SvFLAGS(namesv) |= SVpad_OUR;
327         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
328     }
329
330     av_store(PL_comppad_name, offset, namesv);
331     SvNVX(namesv) = (NV)min;
332     SvIVX(namesv) = max;
333     if (fake)
334         SvFAKE_on(namesv);
335     else {
336         if (!PL_min_intro_pending)
337             PL_min_intro_pending = offset;
338         PL_max_intro_pending = offset;
339         /* XXX DAPM since slot has been allocated, replace
340          * av_store with PL_curpad[offset] ? */
341         if (*name == '@')
342             av_store(PL_comppad, offset, (SV*)newAV());
343         else if (*name == '%')
344             av_store(PL_comppad, offset, (SV*)newHV());
345         SvPADMY_on(PL_curpad[offset]);
346     }
347
348     return offset;
349 }
350
351
352
353
354 /*
355 =for apidoc pad_alloc
356
357 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
358 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
359 for a slot which has no name and and no active value.
360
361 =cut
362 */
363
364 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
365  * or at least rationalise ??? */
366
367
368 PADOFFSET
369 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
370 {
371     SV *sv;
372     I32 retval;
373
374     ASSERT_CURPAD_ACTIVE("pad_alloc");
375
376     if (AvARRAY(PL_comppad) != PL_curpad)
377         Perl_croak(aTHX_ "panic: pad_alloc");
378     if (PL_pad_reset_pending)
379         pad_reset();
380     if (tmptype & SVs_PADMY) {
381         do {
382             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
383         } while (SvPADBUSY(sv));                /* need a fresh one */
384         retval = AvFILLp(PL_comppad);
385     }
386     else {
387         SV **names = AvARRAY(PL_comppad_name);
388         SSize_t names_fill = AvFILLp(PL_comppad_name);
389         for (;;) {
390             /*
391              * "foreach" index vars temporarily become aliases to non-"my"
392              * values.  Thus we must skip, not just pad values that are
393              * marked as current pad values, but also those with names.
394              */
395             /* HVDS why copy to sv here? we don't seem to use it */
396             if (++PL_padix <= names_fill &&
397                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
398                 continue;
399             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
400             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
401                 !IS_PADGV(sv) && !IS_PADCONST(sv))
402                 break;
403         }
404         retval = PL_padix;
405     }
406     SvFLAGS(sv) |= tmptype;
407     PL_curpad = AvARRAY(PL_comppad);
408
409     DEBUG_X(PerlIO_printf(Perl_debug_log,
410           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
411           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
412           PL_op_name[optype]));
413     return (PADOFFSET)retval;
414 }
415
416 /*
417 =for apidoc pad_add_anon
418
419 Add an anon code entry to the current compiling pad
420
421 =cut
422 */
423
424 PADOFFSET
425 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
426 {
427     PADOFFSET ix;
428     SV* name;
429
430     name = NEWSV(1106, 0);
431     sv_upgrade(name, SVt_PVNV);
432     sv_setpvn(name, "&", 1);
433     SvIVX(name) = -1;
434     SvNVX(name) = 1;
435     ix = pad_alloc(op_type, SVs_PADMY);
436     av_store(PL_comppad_name, ix, name);
437     /* XXX DAPM use PL_curpad[] ? */
438     av_store(PL_comppad, ix, sv);
439     SvPADMY_on(sv);
440     return ix;
441 }
442
443
444
445 /*
446 =for apidoc pad_check_dup
447
448 Check for duplicate declarations: report any of:
449      * a my in the current scope with the same name;
450      * an our (anywhere in the pad) with the same name and the same stash
451        as C<ourstash>
452 C<is_our> indicates that the name to check is an 'our' declaration
453
454 =cut
455 */
456
457 /* XXX DAPM integrate this into pad_add_name ??? */
458
459 void
460 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
461 {
462     SV          **svp, *sv;
463     PADOFFSET   top, off;
464
465     ASSERT_CURPAD_ACTIVE("pad_check_dup");
466     if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
467         return; /* nothing to check */
468
469     svp = AvARRAY(PL_comppad_name);
470     top = AvFILLp(PL_comppad_name);
471     /* check the current scope */
472     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
473      * type ? */
474     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
475         if ((sv = svp[off])
476             && sv != &PL_sv_undef
477             && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
478             && (!is_our
479                 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
480             && strEQ(name, SvPVX(sv)))
481         {
482             Perl_warner(aTHX_ packWARN(WARN_MISC),
483                 "\"%s\" variable %s masks earlier declaration in same %s",
484                 (is_our ? "our" : "my"),
485                 name,
486                 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
487             --off;
488             break;
489         }
490     }
491     /* check the rest of the pad */
492     if (is_our) {
493         do {
494             if ((sv = svp[off])
495                 && sv != &PL_sv_undef
496                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
497                 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
498                 && strEQ(name, SvPVX(sv)))
499             {
500                 Perl_warner(aTHX_ packWARN(WARN_MISC),
501                     "\"our\" variable %s redeclared", name);
502                 Perl_warner(aTHX_ packWARN(WARN_MISC),
503                     "\t(Did you mean \"local\" instead of \"our\"?)\n");
504                 break;
505             }
506         } while ( off-- > 0 );
507     }
508 }
509
510
511
512 /*
513 =for apidoc pad_findmy
514
515 Given a lexical name, try to find its offset, first in the current pad,
516 or failing that, in the pads of any lexically enclosing subs (including
517 the complications introduced by eval). If the name is found in an outer pad,
518 then a fake entry is added to the current pad.
519 Returns the offset in the current pad, or NOT_IN_PAD on failure.
520
521 =cut
522 */
523
524 PADOFFSET
525 Perl_pad_findmy(pTHX_ char *name)
526 {
527     I32 off;
528     I32 pendoff = 0;
529     SV *sv;
530     SV **svp = AvARRAY(PL_comppad_name);
531     U32 seq = PL_cop_seqmax;
532     PERL_CONTEXT *cx;
533     CV *outside;
534
535     ASSERT_CURPAD_ACTIVE("pad_findmy");
536     DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy:  \"%s\"\n", name));
537
538     /* The one we're looking for is probably just before comppad_name_fill. */
539     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
540         if ((sv = svp[off]) &&
541             sv != &PL_sv_undef &&
542             (!SvIVX(sv) ||
543              (seq <= (U32)SvIVX(sv) &&
544               seq > (U32)I_32(SvNVX(sv)))) &&
545             strEQ(SvPVX(sv), name))
546         {
547             if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
548                 return (PADOFFSET)off;
549             pendoff = off;      /* this pending def. will override import */
550         }
551     }
552
553     outside = CvOUTSIDE(PL_compcv);
554
555     /* Check if if we're compiling an eval'', and adjust seq to be the
556      * eval's seq number.  This depends on eval'' having a non-null
557      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
558      * identified by CvEVAL being true and CvGV being null. */
559     if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
560         cx = &cxstack[cxstack_ix];
561         if (CxREALEVAL(cx))
562             seq = cx->blk_oldcop->cop_seq;
563     }
564
565     /* See if it's in a nested scope */
566     off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
567     if (!off)                   /* pad_findlex returns 0 for failure...*/
568         return NOT_IN_PAD;      /* ...but we return NOT_IN_PAD for failure */
569
570     /* If there is a pending local definition, this new alias must die */
571     if (pendoff)
572         SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
573     return off;
574 }
575
576
577
578 /*
579 =for apidoc pad_findlex
580
581 Find a named lexical anywhere in a chain of nested pads. Add fake entries
582 in the inner pads if its found in an outer one.
583
584 If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
585
586 =cut
587 */
588
589 #define FINDLEX_NOSEARCH        1       /* don't search outer contexts */
590
591 STATIC PADOFFSET
592 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
593             I32 cx_ix, I32 saweval, U32 flags)
594 {
595     CV *cv;
596     I32 off;
597     SV *sv;
598     register I32 i;
599     register PERL_CONTEXT *cx;
600
601     ASSERT_CURPAD_ACTIVE("pad_findlex");
602     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
603         "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
604             " ix=%ld saweval=%d flags=%lu\n",
605             name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
606             (long)cx_ix, (int)saweval, (unsigned long)flags
607         )
608     );
609
610     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
611         AV *curlist = CvPADLIST(cv);
612         SV **svp = av_fetch(curlist, 0, FALSE);
613         AV *curname;
614
615         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
616             "             searching: cv=0x%"UVxf"\n", PTR2UV(cv))
617         );
618
619         if (!svp || *svp == &PL_sv_undef)
620             continue;
621         curname = (AV*)*svp;
622         svp = AvARRAY(curname);
623         for (off = AvFILLp(curname); off > 0; off--) {
624             I32 depth;
625             AV *oldpad;
626             SV *oldsv;
627
628             if ( ! (
629                     (sv = svp[off]) &&
630                     sv != &PL_sv_undef &&
631                     seq <= (U32)SvIVX(sv) &&
632                     seq > (U32)I_32(SvNVX(sv)) &&
633                     strEQ(SvPVX(sv), name))
634             )
635                 continue;
636
637             depth = CvDEPTH(cv);
638             if (!depth) {
639                 if (newoff) {
640                     if (SvFAKE(sv))
641                         continue;
642                     return 0; /* don't clone from inactive stack frame */
643                 }
644                 depth = 1;
645             }
646
647             oldpad = (AV*)AvARRAY(curlist)[depth];
648             oldsv = *av_fetch(oldpad, off, TRUE);
649
650             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
651                         "             matched:   offset %ld"
652                             " %s(%lu,%lu), sv=0x%"UVxf"\n",
653                         (long)off,
654                         SvFAKE(sv) ? "FAKE " : "",
655                         (unsigned long)I_32(SvNVX(sv)),
656                         (unsigned long)SvIVX(sv),
657                         PTR2UV(oldsv)
658                     )
659             );
660
661             if (!newoff) {              /* Not a mere clone operation. */
662                 newoff = pad_add_name(
663                     SvPVX(sv),
664                     (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
665                     (SvFLAGS(sv) & SVpad_OUR)   ? GvSTASH(sv) : Nullhv,
666                     1  /* fake */
667                 );
668
669                 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
670                     /* "It's closures all the way down." */
671                     CvCLONE_on(PL_compcv);
672                     if (cv == startcv) {
673                         if (CvANON(PL_compcv))
674                             oldsv = Nullsv; /* no need to keep ref */
675                     }
676                     else {
677                         CV *bcv;
678                         for (bcv = startcv;
679                              bcv && bcv != cv && !CvCLONE(bcv);
680                              bcv = CvOUTSIDE(bcv))
681                         {
682                             if (CvANON(bcv)) {
683                                 /* install the missing pad entry in intervening
684                                  * nested subs and mark them cloneable. */
685                                 AV *ocomppad_name = PL_comppad_name;
686                                 PAD *ocomppad = PL_comppad;
687                                 AV *padlist = CvPADLIST(bcv);
688                                 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
689                                 PL_comppad = (AV*)AvARRAY(padlist)[1];
690                                 PL_curpad = AvARRAY(PL_comppad);
691                                 pad_add_name(
692                                     SvPVX(sv),
693                                     (SvFLAGS(sv) & SVpad_TYPED)
694                                         ? SvSTASH(sv) : Nullhv,
695                                     (SvFLAGS(sv) & SVpad_OUR)
696                                         ? GvSTASH(sv) : Nullhv,
697                                     1  /* fake */
698                                 );
699
700                                 PL_comppad_name = ocomppad_name;
701                                 PL_comppad = ocomppad;
702                                 PL_curpad = ocomppad ?
703                                         AvARRAY(ocomppad) : Null(SV **);
704                                 CvCLONE_on(bcv);
705                             }
706                             else {
707                                 if (ckWARN(WARN_CLOSURE)
708                                     && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
709                                 {
710                                     Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
711                                       "Variable \"%s\" may be unavailable",
712                                          name);
713                                 }
714                                 break;
715                             }
716                         }
717                     }
718                 }
719                 else if (!CvUNIQUE(PL_compcv)) {
720                     if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
721                         && !(SvFLAGS(sv) & SVpad_OUR))
722                     {
723                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
724                             "Variable \"%s\" will not stay shared", name);
725                     }
726                 }
727             }
728             av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
729             ASSERT_CURPAD_ACTIVE("pad_findlex 2");
730             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
731                         "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
732                         (long)newoff, PTR2UV(oldsv)
733                     )
734             );
735             return newoff;
736         }
737     }
738
739     if (flags & FINDLEX_NOSEARCH)
740         return 0;
741
742     /* Nothing in current lexical context--try eval's context, if any.
743      * This is necessary to let the perldb get at lexically scoped variables.
744      * XXX This will also probably interact badly with eval tree caching.
745      */
746
747     for (i = cx_ix; i >= 0; i--) {
748         cx = &cxstack[i];
749         switch (CxTYPE(cx)) {
750         default:
751             if (i == 0 && saweval) {
752                 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
753             }
754             break;
755         case CXt_EVAL:
756             switch (cx->blk_eval.old_op_type) {
757             case OP_ENTEREVAL:
758                 if (CxREALEVAL(cx)) {
759                     PADOFFSET off;
760                     saweval = i;
761                     seq = cxstack[i].blk_oldcop->cop_seq;
762                     startcv = cxstack[i].blk_eval.cv;
763                     if (startcv && CvOUTSIDE(startcv)) {
764                         off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
765                                           i - 1, saweval, 0);
766                         if (off)        /* continue looking if not found here */
767                             return off;
768                     }
769                 }
770                 break;
771             case OP_DOFILE:
772             case OP_REQUIRE:
773                 /* require/do must have their own scope */
774                 return 0;
775             }
776             break;
777         case CXt_FORMAT:
778         case CXt_SUB:
779             if (!saweval)
780                 return 0;
781             cv = cx->blk_sub.cv;
782             if (PL_debstash && CvSTASH(cv) == PL_debstash) {    /* ignore DB'* scope */
783                 saweval = i;    /* so we know where we were called from */
784                 seq = cxstack[i].blk_oldcop->cop_seq;
785                 continue;
786             }
787             return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
788         }
789     }
790
791     return 0;
792 }
793
794
795 /*
796 =for apidoc pad_sv
797
798 Get the value at offset po in the current pad.
799 Use macro PAD_SV instead of calling this function directly.
800
801 =cut
802 */
803
804
805 SV *
806 Perl_pad_sv(pTHX_ PADOFFSET po)
807 {
808     ASSERT_CURPAD_ACTIVE("pad_sv");
809
810     if (!po)
811         Perl_croak(aTHX_ "panic: pad_sv po");
812     DEBUG_X(PerlIO_printf(Perl_debug_log,
813         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
814         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
815     );
816     return PL_curpad[po];
817 }
818
819
820 /*
821 =for apidoc pad_setsv
822
823 Set the entry at offset po in the current pad to sv.
824 Use the macro PAD_SETSV() rather than calling this function directly.
825
826 =cut
827 */
828
829 #ifdef DEBUGGING
830 void
831 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
832 {
833     ASSERT_CURPAD_ACTIVE("pad_setsv");
834
835     DEBUG_X(PerlIO_printf(Perl_debug_log,
836         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
837         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
838     );
839     PL_curpad[po] = sv;
840 }
841 #endif
842
843
844
845 /*
846 =for apidoc pad_block_start
847
848 Update the pad compilation state variables on entry to a new block
849
850 =cut
851 */
852
853 /* XXX DAPM perhaps:
854  *      - integrate this in general state-saving routine ???
855  *      - combine with the state-saving going on in pad_new ???
856  *      - introduce a new SAVE type that does all this in one go ?
857  */
858
859 void
860 Perl_pad_block_start(pTHX_ int full)
861 {
862     ASSERT_CURPAD_ACTIVE("pad_block_start");
863     SAVEI32(PL_comppad_name_floor);
864     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
865     if (full)
866         PL_comppad_name_fill = PL_comppad_name_floor;
867     if (PL_comppad_name_floor < 0)
868         PL_comppad_name_floor = 0;
869     SAVEI32(PL_min_intro_pending);
870     SAVEI32(PL_max_intro_pending);
871     PL_min_intro_pending = 0;
872     SAVEI32(PL_comppad_name_fill);
873     SAVEI32(PL_padix_floor);
874     PL_padix_floor = PL_padix;
875     PL_pad_reset_pending = FALSE;
876 }
877
878
879 /*
880 =for apidoc intro_my
881
882 "Introduce" my variables to visible status.
883
884 =cut
885 */
886
887 U32
888 Perl_intro_my(pTHX)
889 {
890     SV **svp;
891     SV *sv;
892     I32 i;
893
894     ASSERT_CURPAD_ACTIVE("intro_my");
895     if (! PL_min_intro_pending)
896         return PL_cop_seqmax;
897
898     svp = AvARRAY(PL_comppad_name);
899     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
900         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
901             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
902             SvNVX(sv) = (NV)PL_cop_seqmax;
903             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
904                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
905                 (long)i, SvPVX(sv),
906                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
907             );
908         }
909     }
910     PL_min_intro_pending = 0;
911     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
912     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
913                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
914
915     return PL_cop_seqmax++;
916 }
917
918 /*
919 =for apidoc pad_leavemy
920
921 Cleanup at end of scope during compilation: set the max seq number for
922 lexicals in this scope and warn of any lexicals that never got introduced.
923
924 =cut
925 */
926
927 void
928 Perl_pad_leavemy(pTHX)
929 {
930     I32 off;
931     SV **svp = AvARRAY(PL_comppad_name);
932     SV *sv;
933
934     PL_pad_reset_pending = FALSE;
935
936     ASSERT_CURPAD_ACTIVE("pad_leavemy");
937     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
938         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
939             if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
940                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
941                                         "%s never introduced", SvPVX(sv));
942         }
943     }
944     /* "Deintroduce" my variables that are leaving with this scope. */
945     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
946         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
947             SvIVX(sv) = PL_cop_seqmax;
948             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
949                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
950                 (long)off, SvPVX(sv),
951                 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
952             );
953         }
954     }
955     PL_cop_seqmax++;
956     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
957             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
958 }
959
960
961 /*
962 =for apidoc pad_swipe
963
964 Abandon the tmp in the current pad at offset po and replace with a
965 new one.
966
967 =cut
968 */
969
970 void
971 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
972 {
973     ASSERT_CURPAD_LEGAL("pad_swipe");
974     if (!PL_curpad)
975         return;
976     if (AvARRAY(PL_comppad) != PL_curpad)
977         Perl_croak(aTHX_ "panic: pad_swipe curpad");
978     if (!po)
979         Perl_croak(aTHX_ "panic: pad_swipe po");
980
981     DEBUG_X(PerlIO_printf(Perl_debug_log,
982                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
983                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
984
985     if (PL_curpad[po])
986         SvPADTMP_off(PL_curpad[po]);
987     if (refadjust)
988         SvREFCNT_dec(PL_curpad[po]);
989
990     PL_curpad[po] = NEWSV(1107,0);
991     SvPADTMP_on(PL_curpad[po]);
992     if ((I32)po < PL_padix)
993         PL_padix = po - 1;
994 }
995
996
997 /*
998 =for apidoc pad_reset
999
1000 Mark all the current temporaries for reuse
1001
1002 =cut
1003 */
1004
1005 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1006  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1007  * on the stack by OPs that use them, there are several ways to get an alias
1008  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1009  * We avoid doing this until we can think of a Better Way.
1010  * GSAR 97-10-29 */
1011 void
1012 Perl_pad_reset(pTHX)
1013 {
1014 #ifdef USE_BROKEN_PAD_RESET
1015     register I32 po;
1016
1017     if (AvARRAY(PL_comppad) != PL_curpad)
1018         Perl_croak(aTHX_ "panic: pad_reset curpad");
1019
1020     DEBUG_X(PerlIO_printf(Perl_debug_log,
1021             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1022             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1023                 (long)PL_padix, (long)PL_padix_floor
1024             )
1025     );
1026
1027     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1028         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1029             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1030                 SvPADTMP_off(PL_curpad[po]);
1031         }
1032         PL_padix = PL_padix_floor;
1033     }
1034 #endif
1035     PL_pad_reset_pending = FALSE;
1036 }
1037
1038
1039 /*
1040 =for apidoc pad_tidy
1041
1042 Tidy up a pad after we've finished compiling it:
1043     * remove most stuff from the pads of anonsub prototypes;
1044     * give it a @_;
1045     * mark tmps as such.
1046
1047 =cut
1048 */
1049
1050 /* XXX DAPM surely most of this stuff should be done properly
1051  * at the right time beforehand, rather than going around afterwards
1052  * cleaning up our mistakes ???
1053  */
1054
1055 void
1056 Perl_pad_tidy(pTHX_ padtidy_type type)
1057 {
1058     PADOFFSET ix;
1059
1060     ASSERT_CURPAD_ACTIVE("pad_tidy");
1061     /* extend curpad to match namepad */
1062     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1063         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1064
1065     if (type == padtidy_SUBCLONE) {
1066         SV **namep = AvARRAY(PL_comppad_name);
1067         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1068             SV *namesv;
1069
1070             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1071                 continue;
1072             /*
1073              * The only things that a clonable function needs in its
1074              * pad are references to outer lexicals and anonymous subs.
1075              * The rest are created anew during cloning.
1076              */
1077             if (!((namesv = namep[ix]) != Nullsv &&
1078                   namesv != &PL_sv_undef &&
1079                   (SvFAKE(namesv) ||
1080                    *SvPVX(namesv) == '&')))
1081             {
1082                 SvREFCNT_dec(PL_curpad[ix]);
1083                 PL_curpad[ix] = Nullsv;
1084             }
1085         }
1086     }
1087     else if (type == padtidy_SUB) {
1088         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1089         AV *av = newAV();                       /* Will be @_ */
1090         av_extend(av, 0);
1091         av_store(PL_comppad, 0, (SV*)av);
1092         AvFLAGS(av) = AVf_REIFY;
1093     }
1094
1095     /* XXX DAPM rationalise these two similar branches */
1096
1097     if (type == padtidy_SUB) {
1098         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1099             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1100                 continue;
1101             if (!SvPADMY(PL_curpad[ix]))
1102                 SvPADTMP_on(PL_curpad[ix]);
1103         }
1104     }
1105     else if (type == padtidy_FORMAT) {
1106         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1107             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1108                 SvPADTMP_on(PL_curpad[ix]);
1109         }
1110     }
1111     PL_curpad = AvARRAY(PL_comppad);
1112 }
1113
1114
1115 /*
1116 =for apidoc pad_free
1117
1118 Free the SV at offet po in the current pad.
1119
1120 =cut
1121 */
1122
1123 /* XXX DAPM integrate with pad_swipe ???? */
1124 void
1125 Perl_pad_free(pTHX_ PADOFFSET po)
1126 {
1127     ASSERT_CURPAD_LEGAL("pad_free");
1128     if (!PL_curpad)
1129         return;
1130     if (AvARRAY(PL_comppad) != PL_curpad)
1131         Perl_croak(aTHX_ "panic: pad_free curpad");
1132     if (!po)
1133         Perl_croak(aTHX_ "panic: pad_free po");
1134
1135     DEBUG_X(PerlIO_printf(Perl_debug_log,
1136             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1137             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1138     );
1139
1140     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1141         SvPADTMP_off(PL_curpad[po]);
1142 #ifdef USE_ITHREADS
1143 #ifdef PERL_COPY_ON_WRITE
1144         if (SvIsCOW(PL_curpad[po])) {
1145             sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1146         } else
1147 #endif
1148             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1149
1150 #endif
1151     }
1152     if ((I32)po < PL_padix)
1153         PL_padix = po - 1;
1154 }
1155
1156
1157
1158 /*
1159 =for apidoc do_dump_pad
1160
1161 Dump the contents of a padlist
1162
1163 =cut
1164 */
1165
1166 void
1167 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1168 {
1169     AV *pad_name;
1170     AV *pad;
1171     SV **pname;
1172     SV **ppad;
1173     SV *namesv;
1174     I32 ix;
1175
1176     if (!padlist) {
1177         return;
1178     }
1179     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1180     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1181     pname = AvARRAY(pad_name);
1182     ppad = AvARRAY(pad);
1183     Perl_dump_indent(aTHX_ level, file,
1184             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1185             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1186     );
1187
1188     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1189         namesv = pname[ix];
1190         if (namesv && namesv == &PL_sv_undef) {
1191             namesv = Nullsv;
1192         }
1193         if (namesv) {
1194             Perl_dump_indent(aTHX_ level+1, file,
1195                 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1196                 (int) ix,
1197                 PTR2UV(ppad[ix]),
1198                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1199                 SvFAKE(namesv) ? "FAKE" : "    ",
1200                 (unsigned long)I_32(SvNVX(namesv)),
1201                 (unsigned long)SvIVX(namesv),
1202                 SvPVX(namesv)
1203             );
1204         }
1205         else if (full) {
1206             Perl_dump_indent(aTHX_ level+1, file,
1207                 "%2d. 0x%"UVxf"<%lu>\n",
1208                 (int) ix,
1209                 PTR2UV(ppad[ix]),
1210                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1211             );
1212         }
1213     }
1214 }
1215
1216
1217
1218 /*
1219 =for apidoc cv_dump
1220
1221 dump the contents of a CV
1222
1223 =cut
1224 */
1225
1226 #ifdef DEBUGGING
1227 STATIC void
1228 S_cv_dump(pTHX_ CV *cv, char *title)
1229 {
1230     CV *outside = CvOUTSIDE(cv);
1231     AV* padlist = CvPADLIST(cv);
1232
1233     PerlIO_printf(Perl_debug_log,
1234                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1235                   title,
1236                   PTR2UV(cv),
1237                   (CvANON(cv) ? "ANON"
1238                    : (cv == PL_main_cv) ? "MAIN"
1239                    : CvUNIQUE(cv) ? "UNIQUE"
1240                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1241                   PTR2UV(outside),
1242                   (!outside ? "null"
1243                    : CvANON(outside) ? "ANON"
1244                    : (outside == PL_main_cv) ? "MAIN"
1245                    : CvUNIQUE(outside) ? "UNIQUE"
1246                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1247
1248     PerlIO_printf(Perl_debug_log,
1249                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1250     do_dump_pad(1, Perl_debug_log, padlist, 1);
1251 }
1252 #endif /* DEBUGGING */
1253
1254
1255
1256
1257
1258 /*
1259 =for apidoc cv_clone
1260
1261 Clone a CV: make a new CV which points to the same code etc, but which
1262 has a newly-created pad built by copying the prototype pad and capturing
1263 any outer lexicals.
1264
1265 =cut
1266 */
1267
1268 CV *
1269 Perl_cv_clone(pTHX_ CV *proto)
1270 {
1271     CV *cv;
1272
1273     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
1274     cv = cv_clone2(proto, CvOUTSIDE(proto));
1275     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
1276     return cv;
1277 }
1278
1279
1280 /* XXX DAPM separate out cv and paddish bits ???
1281  * ideally the CV-related stuff shouldn't be in pad.c - how about
1282  * a cv.c? */
1283
1284 STATIC CV *
1285 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1286 {
1287     I32 ix;
1288     AV* protopadlist = CvPADLIST(proto);
1289     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1290     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1291     SV** pname = AvARRAY(protopad_name);
1292     SV** ppad = AvARRAY(protopad);
1293     I32 fname = AvFILLp(protopad_name);
1294     I32 fpad = AvFILLp(protopad);
1295     AV* comppadlist;
1296     CV* cv;
1297
1298     assert(!CvUNIQUE(proto));
1299
1300     ENTER;
1301     SAVESPTR(PL_compcv);
1302
1303     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1304     sv_upgrade((SV *)cv, SvTYPE(proto));
1305     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1306     CvCLONED_on(cv);
1307
1308 #ifdef USE_ITHREADS
1309     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1310                                         : savepv(CvFILE(proto));
1311 #else
1312     CvFILE(cv)          = CvFILE(proto);
1313 #endif
1314     CvGV(cv)            = CvGV(proto);
1315     CvSTASH(cv)         = CvSTASH(proto);
1316     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1317     CvSTART(cv)         = CvSTART(proto);
1318     if (outside)
1319         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
1320
1321     if (SvPOK(proto))
1322         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1323
1324     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1325
1326     for (ix = fname; ix >= 0; ix--)
1327         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1328
1329     av_fill(PL_comppad, fpad);
1330     PL_curpad = AvARRAY(PL_comppad);
1331
1332     for (ix = fpad; ix > 0; ix--) {
1333         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1334         if (namesv && namesv != &PL_sv_undef) {
1335             char *name = SvPVX(namesv);    /* XXX */
1336             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
1337                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
1338                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
1339                 if (!off)
1340                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1341                 else if (off != ix)
1342                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1343             }
1344             else {                              /* our own lexical */
1345                 SV* sv;
1346                 if (*name == '&') {
1347                     /* anon code -- we'll come back for it */
1348                     sv = SvREFCNT_inc(ppad[ix]);
1349                 }
1350                 else if (*name == '@')
1351                     sv = (SV*)newAV();
1352                 else if (*name == '%')
1353                     sv = (SV*)newHV();
1354                 else
1355                     sv = NEWSV(0, 0);
1356                 if (!SvPADBUSY(sv))
1357                     SvPADMY_on(sv);
1358                 PL_curpad[ix] = sv;
1359             }
1360         }
1361         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1362             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1363         }
1364         else {
1365             SV* sv = NEWSV(0, 0);
1366             SvPADTMP_on(sv);
1367             PL_curpad[ix] = sv;
1368         }
1369     }
1370
1371     /* Now that vars are all in place, clone nested closures. */
1372
1373     for (ix = fpad; ix > 0; ix--) {
1374         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1375         if (namesv
1376             && namesv != &PL_sv_undef
1377             && !(SvFLAGS(namesv) & SVf_FAKE)
1378             && *SvPVX(namesv) == '&'
1379             && CvCLONE(ppad[ix]))
1380         {
1381             CV *kid = cv_clone2((CV*)ppad[ix], cv);
1382             SvREFCNT_dec(ppad[ix]);
1383             CvCLONE_on(kid);
1384             SvPADMY_on(kid);
1385             PL_curpad[ix] = (SV*)kid;
1386         }
1387     }
1388
1389     DEBUG_Xv(
1390         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1391         cv_dump(outside, "Outside");
1392         cv_dump(proto,   "Proto");
1393         cv_dump(cv,      "To");
1394     );
1395
1396     LEAVE;
1397
1398     if (CvCONST(cv)) {
1399         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1400         assert(const_sv);
1401         /* constant sub () { $x } closing over $x - see lib/constant.pm */
1402         SvREFCNT_dec(cv);
1403         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1404     }
1405
1406     return cv;
1407 }
1408
1409
1410 /*
1411 =for apidoc pad_fixup_inner_anons
1412
1413 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1414 old_cv to new_cv if necessary.
1415
1416 =cut
1417 */
1418
1419 void
1420 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1421 {
1422     I32 ix;
1423     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1424     AV *comppad = (AV*)AvARRAY(padlist)[1];
1425     SV **namepad = AvARRAY(comppad_name);
1426     SV **curpad = AvARRAY(comppad);
1427     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1428         SV *namesv = namepad[ix];
1429         if (namesv && namesv != &PL_sv_undef
1430             && *SvPVX(namesv) == '&')
1431         {
1432             CV *innercv = (CV*)curpad[ix];
1433             if (CvOUTSIDE(innercv) == old_cv) {
1434                 CvOUTSIDE(innercv) = new_cv;
1435                 if (!CvANON(innercv) || CvCLONED(innercv)) {
1436                     (void)SvREFCNT_inc(new_cv);
1437                     SvREFCNT_dec(old_cv);
1438                 }
1439             }
1440         }
1441     }
1442 }
1443
1444 /*
1445 =for apidoc pad_push
1446
1447 Push a new pad frame onto the padlist, unless there's already a pad at
1448 this depth, in which case don't bother creating a new one.
1449 If has_args is true, give the new pad an @_ in slot zero.
1450
1451 =cut
1452 */
1453
1454 void
1455 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1456 {
1457     if (depth <= AvFILLp(padlist))
1458         return;
1459
1460     {
1461         SV** svp = AvARRAY(padlist);
1462         AV *newpad = newAV();
1463         SV **oldpad = AvARRAY(svp[depth-1]);
1464         I32 ix = AvFILLp((AV*)svp[1]);
1465         I32 names_fill = AvFILLp((AV*)svp[0]);
1466         SV** names = AvARRAY(svp[0]);
1467         SV* sv;
1468         for ( ;ix > 0; ix--) {
1469             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1470                 char *name = SvPVX(names[ix]);
1471                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1472                     /* outer lexical or anon code */
1473                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1474                 }
1475                 else {          /* our own lexical */
1476                     if (*name == '@')
1477                         av_store(newpad, ix, sv = (SV*)newAV());
1478                     else if (*name == '%')
1479                         av_store(newpad, ix, sv = (SV*)newHV());
1480                     else
1481                         av_store(newpad, ix, sv = NEWSV(0, 0));
1482                     SvPADMY_on(sv);
1483                 }
1484             }
1485             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1486                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1487             }
1488             else {
1489                 /* save temporaries on recursion? */
1490                 av_store(newpad, ix, sv = NEWSV(0, 0));
1491                 SvPADTMP_on(sv);
1492             }
1493         }
1494         if (has_args) {
1495             AV* av = newAV();
1496             av_extend(av, 0);
1497             av_store(newpad, 0, (SV*)av);
1498             AvFLAGS(av) = AVf_REIFY;
1499         }
1500         av_store(padlist, depth, (SV*)newpad);
1501         AvFILLp(padlist) = depth;
1502     }
1503 }