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