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