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