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