Minor nits in perlsyn.pod
[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
541     return pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
542                 Null(SV**), &out_sv, &out_flags);
543 }
544
545
546 /*
547 =for apidoc pad_findlex
548
549 Find a named lexical anywhere in a chain of nested pads. Add fake entries
550 in the inner pads if it's found in an outer one.
551
552 Returns the offset in the bottom pad of the lex or the fake lex.
553 cv is the CV in which to start the search, and seq is the current cop_seq
554 to match against. If warn is true, print appropriate warnings.  The out_*
555 vars return values, and so are pointers to where the returned values
556 should be stored. out_capture, if non-null, requests that the innermost
557 instance of the lexical is captured; out_name_sv is set to the innermost
558 matched namesv or fake namesv; out_flags returns the flags normally
559 associated with the IVX field of a fake namesv.
560
561 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
562 then comes back down, adding fake entries as it goes. It has to be this way
563 because fake namesvs in anon protoypes have to store in NVX the index into
564 the parent pad.
565
566 =cut
567 */
568
569 /* Flags set in the SvIVX field of FAKE namesvs */
570
571 #define PAD_FAKELEX_ANON   1 /* the lex is declared in an ANON, or ... */
572 #define PAD_FAKELEX_MULTI  2 /* the lex can be instantiated multiple times */
573
574 /* the CV has finished being compiled. This is not a sufficient test for
575  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
576 #define CvCOMPILED(cv)  CvROOT(cv)
577
578 /* the CV does late binding of its lexicals */
579 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
580
581
582 STATIC PADOFFSET
583 S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
584         SV** out_capture, SV** out_name_sv, int *out_flags)
585 {
586     I32 offset, new_offset;
587     SV *new_capture;
588     SV **new_capturep;
589     AV *padlist = CvPADLIST(cv);
590
591     *out_flags = 0;
592
593     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
594         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
595         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
596
597     /* first, search this pad */
598
599     if (padlist) { /* not an undef CV */
600         I32 fake_offset = 0;
601         AV *nameav = (AV*)AvARRAY(padlist)[0];
602         SV **name_svp = AvARRAY(nameav);
603
604         for (offset = AvFILLp(nameav); offset > 0; offset--) {
605             SV *namesv = name_svp[offset];
606             if (namesv && namesv != &PL_sv_undef
607                     && strEQ(SvPVX(namesv), name))
608             {
609                 if (SvFAKE(namesv))
610                     fake_offset = offset; /* in case we don't find a real one */
611                 else if (  seq >  (U32)I_32(SvNVX(namesv))      /* min */
612                         && seq <= (U32)SvIVX(namesv))           /* max */
613                     break;
614             }
615         }
616
617         if (offset > 0 || fake_offset > 0 ) { /* a match! */
618             if (offset > 0) { /* not fake */
619                 fake_offset = 0;
620                 *out_name_sv = name_svp[offset]; /* return the namesv */
621
622                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
623                  * instances. For now, we just test !CvUNIQUE(cv), but
624                  * ideally, we should detect my's declared within loops
625                  * etc - this would allow a wider range of 'not stayed
626                  * shared' warnings. We also treated alreadly-compiled
627                  * lexes as not multi as viewed from evals. */
628
629                 *out_flags = CvANON(cv) ?
630                         PAD_FAKELEX_ANON :
631                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
632                                 ? PAD_FAKELEX_MULTI : 0;
633
634                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
635                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
636                     PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
637                     (long)SvIVX(*out_name_sv)));
638             }
639             else { /* fake match */
640                 offset = fake_offset;
641                 *out_name_sv = name_svp[offset]; /* return the namesv */
642                 *out_flags = SvIVX(*out_name_sv);
643                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
644                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%x index=%lu\n",
645                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
646                         (unsigned long)SvNVX(*out_name_sv) 
647                 ));
648             }
649
650             /* return the lex? */
651
652             if (out_capture) {
653
654                 /* our ? */
655                 if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) {
656                     *out_capture = Nullsv;
657                     return offset;
658                 }
659
660                 /* trying to capture from an anon prototype? */
661                 if (CvCOMPILED(cv)
662                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
663                         : *out_flags & PAD_FAKELEX_ANON)
664                 {
665                     if (warn && ckWARN(WARN_CLOSURE))
666                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
667                             "Variable \"%s\" is not available", name);
668                     *out_capture = Nullsv;
669                 }
670
671                 /* real value */
672                 else {
673                     int newwarn = warn;
674                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
675                          && warn && ckWARN(WARN_CLOSURE)) {
676                         newwarn = 0;
677                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
678                             "Variable \"%s\" will not stay shared", name);
679                     }
680
681                     if (fake_offset && CvANON(cv)
682                             && CvCLONE(cv) &&!CvCLONED(cv))
683                     {
684                         SV *n;
685                         /* not yet caught - look further up */
686                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
687                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
688                             PTR2UV(cv)));
689                         n = *out_name_sv;
690                         pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv),
691                             newwarn, out_capture, out_name_sv, out_flags);
692                         *out_name_sv = n;
693                         return offset;
694                     }
695
696                     *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
697                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
698                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
699                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
700                         PTR2UV(cv), *out_capture));
701
702                     if (SvPADSTALE(*out_capture)) {
703                         if (ckWARN(WARN_CLOSURE))
704                             Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
705                                 "Variable \"%s\" is not available", name);
706                         *out_capture = Nullsv;
707                     }
708                 }
709                 if (!*out_capture) {
710                     if (*name == '@')
711                         *out_capture = sv_2mortal((SV*)newAV());
712                     else if (*name == '%')
713                         *out_capture = sv_2mortal((SV*)newHV());
714                     else
715                         *out_capture = sv_newmortal();
716                 }
717             }
718
719             return offset;
720         }
721     }
722
723     /* it's not in this pad - try above */
724
725     if (!CvOUTSIDE(cv))
726         return NOT_IN_PAD;
727     
728     /* out_capture non-null means caller wants us to capture lex; in
729      * addition we capture ourselves unless it's an ANON/format */
730     new_capturep = out_capture ? out_capture :
731                 CvLATE(cv) ? Null(SV**) : &new_capture;
732
733     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
734                 new_capturep, out_name_sv, out_flags);
735     if (offset == NOT_IN_PAD)
736         return NOT_IN_PAD;
737     
738     /* found in an outer CV. Add appropriate fake entry to this pad */
739
740     /* don't add new fake entries (via eval) to CVs that we have already
741      * finished compiling, or to undef CVs */
742     if (CvCOMPILED(cv) || !padlist)
743         return 0; /* this dummy (and invalid) value isnt used by the caller */
744
745     {
746         SV *new_namesv;
747         AV *ocomppad_name = PL_comppad_name;
748         PAD *ocomppad = PL_comppad;
749         PL_comppad_name = (AV*)AvARRAY(padlist)[0];
750         PL_comppad = (AV*)AvARRAY(padlist)[1];
751         PL_curpad = AvARRAY(PL_comppad);
752
753         new_offset = pad_add_name(
754             SvPVX(*out_name_sv),
755             (SvFLAGS(*out_name_sv) & SVpad_TYPED)
756                     ? SvSTASH(*out_name_sv) : Nullhv,
757             (SvFLAGS(*out_name_sv) & SVpad_OUR)
758                     ? GvSTASH(*out_name_sv) : Nullhv,
759             1  /* fake */
760         );
761
762         new_namesv = AvARRAY(PL_comppad_name)[new_offset];
763         SvIVX(new_namesv) = *out_flags;
764
765         SvNVX(new_namesv) = (NV)0;
766         if (SvFLAGS(new_namesv) & SVpad_OUR) {
767            /* do nothing */
768         }
769         else if (CvLATE(cv)) {
770             /* delayed creation - just note the offset within parent pad */
771             SvNVX(new_namesv) = (NV)offset;
772             CvCLONE_on(cv);
773         }
774         else {
775             /* immediate creation - capture outer value right now */
776             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
777             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
778                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
779                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
780         }
781         *out_name_sv = new_namesv;
782         *out_flags = SvIVX(new_namesv);
783
784         PL_comppad_name = ocomppad_name;
785         PL_comppad = ocomppad;
786         PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **);
787     }
788     return new_offset;
789 }
790
791                 
792 /*
793 =for apidoc pad_sv
794
795 Get the value at offset po in the current pad.
796 Use macro PAD_SV instead of calling this function directly.
797
798 =cut
799 */
800
801
802 SV *
803 Perl_pad_sv(pTHX_ PADOFFSET po)
804 {
805     ASSERT_CURPAD_ACTIVE("pad_sv");
806
807     if (!po)
808         Perl_croak(aTHX_ "panic: pad_sv po");
809     DEBUG_X(PerlIO_printf(Perl_debug_log,
810         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
811         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
812     );
813     return PL_curpad[po];
814 }
815
816
817 /*
818 =for apidoc pad_setsv
819
820 Set the entry at offset po in the current pad to sv.
821 Use the macro PAD_SETSV() rather than calling this function directly.
822
823 =cut
824 */
825
826 #ifdef DEBUGGING
827 void
828 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
829 {
830     ASSERT_CURPAD_ACTIVE("pad_setsv");
831
832     DEBUG_X(PerlIO_printf(Perl_debug_log,
833         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
834         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
835     );
836     PL_curpad[po] = sv;
837 }
838 #endif
839
840
841
842 /*
843 =for apidoc pad_block_start
844
845 Update the pad compilation state variables on entry to a new block
846
847 =cut
848 */
849
850 /* XXX DAPM perhaps:
851  *      - integrate this in general state-saving routine ???
852  *      - combine with the state-saving going on in pad_new ???
853  *      - introduce a new SAVE type that does all this in one go ?
854  */
855
856 void
857 Perl_pad_block_start(pTHX_ int full)
858 {
859     ASSERT_CURPAD_ACTIVE("pad_block_start");
860     SAVEI32(PL_comppad_name_floor);
861     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
862     if (full)
863         PL_comppad_name_fill = PL_comppad_name_floor;
864     if (PL_comppad_name_floor < 0)
865         PL_comppad_name_floor = 0;
866     SAVEI32(PL_min_intro_pending);
867     SAVEI32(PL_max_intro_pending);
868     PL_min_intro_pending = 0;
869     SAVEI32(PL_comppad_name_fill);
870     SAVEI32(PL_padix_floor);
871     PL_padix_floor = PL_padix;
872     PL_pad_reset_pending = FALSE;
873 }
874
875
876 /*
877 =for apidoc intro_my
878
879 "Introduce" my variables to visible status.
880
881 =cut
882 */
883
884 U32
885 Perl_intro_my(pTHX)
886 {
887     SV **svp;
888     SV *sv;
889     I32 i;
890
891     ASSERT_CURPAD_ACTIVE("intro_my");
892     if (! PL_min_intro_pending)
893         return PL_cop_seqmax;
894
895     svp = AvARRAY(PL_comppad_name);
896     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
897         if ((sv = svp[i]) && sv != &PL_sv_undef
898                 && !SvFAKE(sv) && !SvIVX(sv))
899         {
900             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
901             SvNVX(sv) = (NV)PL_cop_seqmax;
902             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
903                 "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
904                 (long)i, SvPVX(sv),
905                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
906             );
907         }
908     }
909     PL_min_intro_pending = 0;
910     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
911     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
912                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
913
914     return PL_cop_seqmax++;
915 }
916
917 /*
918 =for apidoc pad_leavemy
919
920 Cleanup at end of scope during compilation: set the max seq number for
921 lexicals in this scope and warn of any lexicals that never got introduced.
922
923 =cut
924 */
925
926 void
927 Perl_pad_leavemy(pTHX)
928 {
929     I32 off;
930     SV **svp = AvARRAY(PL_comppad_name);
931     SV *sv;
932
933     PL_pad_reset_pending = FALSE;
934
935     ASSERT_CURPAD_ACTIVE("pad_leavemy");
936     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
937         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
938             if ((sv = svp[off]) && sv != &PL_sv_undef
939                     && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
940                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
941                                         "%"SVf" never introduced", sv);
942         }
943     }
944     /* "Deintroduce" my variables that are leaving with this scope. */
945     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
946         if ((sv = svp[off]) && sv != &PL_sv_undef
947                 && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
948         {
949             SvIVX(sv) = PL_cop_seqmax;
950             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
951                 "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
952                 (long)off, SvPVX(sv),
953                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
954             );
955         }
956     }
957     PL_cop_seqmax++;
958     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
959             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
960 }
961
962
963 /*
964 =for apidoc pad_swipe
965
966 Abandon the tmp in the current pad at offset po and replace with a
967 new one.
968
969 =cut
970 */
971
972 void
973 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
974 {
975     ASSERT_CURPAD_LEGAL("pad_swipe");
976     if (!PL_curpad)
977         return;
978     if (AvARRAY(PL_comppad) != PL_curpad)
979         Perl_croak(aTHX_ "panic: pad_swipe curpad");
980     if (!po)
981         Perl_croak(aTHX_ "panic: pad_swipe po");
982
983     DEBUG_X(PerlIO_printf(Perl_debug_log,
984                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
985                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
986
987     if (PL_curpad[po])
988         SvPADTMP_off(PL_curpad[po]);
989     if (refadjust)
990         SvREFCNT_dec(PL_curpad[po]);
991
992     PL_curpad[po] = NEWSV(1107,0);
993     SvPADTMP_on(PL_curpad[po]);
994     if ((I32)po < PL_padix)
995         PL_padix = po - 1;
996 }
997
998
999 /*
1000 =for apidoc pad_reset
1001
1002 Mark all the current temporaries for reuse
1003
1004 =cut
1005 */
1006
1007 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1008  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1009  * on the stack by OPs that use them, there are several ways to get an alias
1010  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1011  * We avoid doing this until we can think of a Better Way.
1012  * GSAR 97-10-29 */
1013 void
1014 Perl_pad_reset(pTHX)
1015 {
1016 #ifdef USE_BROKEN_PAD_RESET
1017     register I32 po;
1018
1019     if (AvARRAY(PL_comppad) != PL_curpad)
1020         Perl_croak(aTHX_ "panic: pad_reset curpad");
1021
1022     DEBUG_X(PerlIO_printf(Perl_debug_log,
1023             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1024             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1025                 (long)PL_padix, (long)PL_padix_floor
1026             )
1027     );
1028
1029     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1030         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1031             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1032                 SvPADTMP_off(PL_curpad[po]);
1033         }
1034         PL_padix = PL_padix_floor;
1035     }
1036 #endif
1037     PL_pad_reset_pending = FALSE;
1038 }
1039
1040
1041 /*
1042 =for apidoc pad_tidy
1043
1044 Tidy up a pad after we've finished compiling it:
1045     * remove most stuff from the pads of anonsub prototypes;
1046     * give it a @_;
1047     * mark tmps as such.
1048
1049 =cut
1050 */
1051
1052 /* XXX DAPM surely most of this stuff should be done properly
1053  * at the right time beforehand, rather than going around afterwards
1054  * cleaning up our mistakes ???
1055  */
1056
1057 void
1058 Perl_pad_tidy(pTHX_ padtidy_type type)
1059 {
1060     PADOFFSET ix;
1061     CV *cv;
1062
1063     ASSERT_CURPAD_ACTIVE("pad_tidy");
1064
1065     /* If this CV has had any 'eval-capable' ops planted in it
1066      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1067      * anon prototypes in the chain of CVs should be marked as cloneable,
1068      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1069      * the right CvOUTSIDE.
1070      * If running with -d, *any* sub may potentially have an eval
1071      * excuted within it.
1072      */
1073
1074     if (PL_cv_has_eval || PL_perldb) {
1075         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1076             if (cv != PL_compcv && CvCOMPILED(cv))
1077                 break; /* no need to mark already-compiled code */
1078             if (CvANON(cv)) {
1079                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1080                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1081                 CvCLONE_on(cv);
1082             }
1083         }
1084     }
1085
1086     /* extend curpad to match namepad */
1087     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1088         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1089
1090     if (type == padtidy_SUBCLONE) {
1091         SV **namep = AvARRAY(PL_comppad_name);
1092
1093         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1094             SV *namesv;
1095
1096             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1097                 continue;
1098             /*
1099              * The only things that a clonable function needs in its
1100              * pad are anonymous subs.
1101              * The rest are created anew during cloning.
1102              */
1103             if (!((namesv = namep[ix]) != Nullsv &&
1104                   namesv != &PL_sv_undef &&
1105                    *SvPVX(namesv) == '&'))
1106             {
1107                 SvREFCNT_dec(PL_curpad[ix]);
1108                 PL_curpad[ix] = Nullsv;
1109             }
1110         }
1111     }
1112     else if (type == padtidy_SUB) {
1113         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1114         AV *av = newAV();                       /* Will be @_ */
1115         av_extend(av, 0);
1116         av_store(PL_comppad, 0, (SV*)av);
1117         AvFLAGS(av) = AVf_REIFY;
1118     }
1119
1120     /* XXX DAPM rationalise these two similar branches */
1121
1122     if (type == padtidy_SUB) {
1123         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1124             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1125                 continue;
1126             if (!SvPADMY(PL_curpad[ix]))
1127                 SvPADTMP_on(PL_curpad[ix]);
1128         }
1129     }
1130     else if (type == padtidy_FORMAT) {
1131         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1132             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1133                 SvPADTMP_on(PL_curpad[ix]);
1134         }
1135     }
1136     PL_curpad = AvARRAY(PL_comppad);
1137 }
1138
1139
1140 /*
1141 =for apidoc pad_free
1142
1143 Free the SV at offet po in the current pad.
1144
1145 =cut
1146 */
1147
1148 /* XXX DAPM integrate with pad_swipe ???? */
1149 void
1150 Perl_pad_free(pTHX_ PADOFFSET po)
1151 {
1152     ASSERT_CURPAD_LEGAL("pad_free");
1153     if (!PL_curpad)
1154         return;
1155     if (AvARRAY(PL_comppad) != PL_curpad)
1156         Perl_croak(aTHX_ "panic: pad_free curpad");
1157     if (!po)
1158         Perl_croak(aTHX_ "panic: pad_free po");
1159
1160     DEBUG_X(PerlIO_printf(Perl_debug_log,
1161             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1162             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1163     );
1164
1165     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1166         SvPADTMP_off(PL_curpad[po]);
1167 #ifdef USE_ITHREADS
1168         /* SV could be a shared hash key (eg bugid #19022) */
1169         if (
1170 #ifdef PERL_COPY_ON_WRITE
1171             !SvIsCOW(PL_curpad[po])
1172 #else
1173             !SvFAKE(PL_curpad[po])
1174 #endif
1175             )
1176             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1177 #endif
1178     }
1179     if ((I32)po < PL_padix)
1180         PL_padix = po - 1;
1181 }
1182
1183
1184
1185 /*
1186 =for apidoc do_dump_pad
1187
1188 Dump the contents of a padlist
1189
1190 =cut
1191 */
1192
1193 void
1194 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1195 {
1196     AV *pad_name;
1197     AV *pad;
1198     SV **pname;
1199     SV **ppad;
1200     SV *namesv;
1201     I32 ix;
1202
1203     if (!padlist) {
1204         return;
1205     }
1206     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1207     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1208     pname = AvARRAY(pad_name);
1209     ppad = AvARRAY(pad);
1210     Perl_dump_indent(aTHX_ level, file,
1211             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1212             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1213     );
1214
1215     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1216         namesv = pname[ix];
1217         if (namesv && namesv == &PL_sv_undef) {
1218             namesv = Nullsv;
1219         }
1220         if (namesv) {
1221             if (SvFAKE(namesv))
1222                 Perl_dump_indent(aTHX_ level+1, file,
1223                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
1224                     (int) ix,
1225                     PTR2UV(ppad[ix]),
1226                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1227                     SvPVX(namesv),
1228                     (unsigned long)SvIVX(namesv),
1229                     (unsigned long)SvNVX(namesv)
1230
1231                 );
1232             else
1233                 Perl_dump_indent(aTHX_ level+1, file,
1234                     "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
1235                     (int) ix,
1236                     PTR2UV(ppad[ix]),
1237                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1238                     (long)I_32(SvNVX(namesv)),
1239                     (long)SvIVX(namesv),
1240                     SvPVX(namesv)
1241                 );
1242         }
1243         else if (full) {
1244             Perl_dump_indent(aTHX_ level+1, file,
1245                 "%2d. 0x%"UVxf"<%lu>\n",
1246                 (int) ix,
1247                 PTR2UV(ppad[ix]),
1248                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1249             );
1250         }
1251     }
1252 }
1253
1254
1255
1256 /*
1257 =for apidoc cv_dump
1258
1259 dump the contents of a CV
1260
1261 =cut
1262 */
1263
1264 #ifdef DEBUGGING
1265 STATIC void
1266 S_cv_dump(pTHX_ CV *cv, char *title)
1267 {
1268     CV *outside = CvOUTSIDE(cv);
1269     AV* padlist = CvPADLIST(cv);
1270
1271     PerlIO_printf(Perl_debug_log,
1272                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1273                   title,
1274                   PTR2UV(cv),
1275                   (CvANON(cv) ? "ANON"
1276                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1277                    : (cv == PL_main_cv) ? "MAIN"
1278                    : CvUNIQUE(cv) ? "UNIQUE"
1279                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1280                   PTR2UV(outside),
1281                   (!outside ? "null"
1282                    : CvANON(outside) ? "ANON"
1283                    : (outside == PL_main_cv) ? "MAIN"
1284                    : CvUNIQUE(outside) ? "UNIQUE"
1285                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1286
1287     PerlIO_printf(Perl_debug_log,
1288                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1289     do_dump_pad(1, Perl_debug_log, padlist, 1);
1290 }
1291 #endif /* DEBUGGING */
1292
1293
1294
1295
1296
1297 /*
1298 =for apidoc cv_clone
1299
1300 Clone a CV: make a new CV which points to the same code etc, but which
1301 has a newly-created pad built by copying the prototype pad and capturing
1302 any outer lexicals.
1303
1304 =cut
1305 */
1306
1307 CV *
1308 Perl_cv_clone(pTHX_ CV *proto)
1309 {
1310     I32 ix;
1311     AV* protopadlist = CvPADLIST(proto);
1312     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1313     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1314     SV** pname = AvARRAY(protopad_name);
1315     SV** ppad = AvARRAY(protopad);
1316     I32 fname = AvFILLp(protopad_name);
1317     I32 fpad = AvFILLp(protopad);
1318     AV* comppadlist;
1319     CV* cv;
1320     SV** outpad;
1321     CV* outside;
1322     long depth;
1323
1324     assert(!CvUNIQUE(proto));
1325
1326     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1327      * to a prototype; we instead want the cloned parent who called us.
1328      * Note that in general for formats, CvOUTSIDE != find_runcv */
1329
1330     outside = CvOUTSIDE(proto);
1331     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1332         outside = find_runcv(NULL);
1333     depth = CvDEPTH(outside);
1334     assert(depth || SvTYPE(proto) == SVt_PVFM);
1335     if (!depth)
1336         depth = 1;
1337     assert(CvPADLIST(outside));
1338
1339     ENTER;
1340     SAVESPTR(PL_compcv);
1341
1342     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1343     sv_upgrade((SV *)cv, SvTYPE(proto));
1344     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1345     CvCLONED_on(cv);
1346
1347 #ifdef USE_ITHREADS
1348     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1349                                         : savepv(CvFILE(proto));
1350 #else
1351     CvFILE(cv)          = CvFILE(proto);
1352 #endif
1353     CvGV(cv)            = CvGV(proto);
1354     CvSTASH(cv)         = CvSTASH(proto);
1355     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1356     CvSTART(cv)         = CvSTART(proto);
1357     CvOUTSIDE(cv)       = (CV*)SvREFCNT_inc(outside);
1358     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1359
1360     if (SvPOK(proto))
1361         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1362
1363     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1364
1365     av_fill(PL_comppad, fpad);
1366     for (ix = fname; ix >= 0; ix--)
1367         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1368
1369     PL_curpad = AvARRAY(PL_comppad);
1370
1371     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1372
1373     for (ix = fpad; ix > 0; ix--) {
1374         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1375         SV *sv = Nullsv;
1376         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1377             if (SvFAKE(namesv)) {   /* lexical from outside? */
1378                 sv = outpad[(I32)SvNVX(namesv)];
1379                 assert(sv);
1380                 /* formats may have an inactive parent */
1381                 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1382                     if (ckWARN(WARN_CLOSURE))
1383                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1384                             "Variable \"%s\" is not available", SvPVX(namesv));
1385                     sv = Nullsv;
1386                 }
1387                 else {
1388                     assert(!SvPADSTALE(sv));
1389                     sv = SvREFCNT_inc(sv);
1390                 }
1391             }
1392             if (!sv) {
1393                 char *name = SvPVX(namesv);
1394                 if (*name == '&')
1395                     sv = SvREFCNT_inc(ppad[ix]);
1396                 else if (*name == '@')
1397                     sv = (SV*)newAV();
1398                 else if (*name == '%')
1399                     sv = (SV*)newHV();
1400                 else
1401                     sv = NEWSV(0, 0);
1402                 SvPADMY_on(sv);
1403             }
1404         }
1405         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1406             sv = SvREFCNT_inc(ppad[ix]);
1407         }
1408         else {
1409             sv = NEWSV(0, 0);
1410             SvPADTMP_on(sv);
1411         }
1412         PL_curpad[ix] = sv;
1413     }
1414
1415     DEBUG_Xv(
1416         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1417         cv_dump(outside, "Outside");
1418         cv_dump(proto,   "Proto");
1419         cv_dump(cv,      "To");
1420     );
1421
1422     LEAVE;
1423
1424     if (CvCONST(cv)) {
1425         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1426          * The prototype was marked as a candiate for const-ization,
1427          * so try to grab the current const value, and if successful,
1428          * turn into a const sub:
1429          */
1430         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1431         if (const_sv) {
1432             SvREFCNT_dec(cv);
1433             cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1434         }
1435         else {
1436             CvCONST_off(cv);
1437         }
1438     }
1439
1440     return cv;
1441 }
1442
1443
1444 /*
1445 =for apidoc pad_fixup_inner_anons
1446
1447 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1448 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1449 moved to a pre-existing CV struct.
1450
1451 =cut
1452 */
1453
1454 void
1455 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1456 {
1457     I32 ix;
1458     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1459     AV *comppad = (AV*)AvARRAY(padlist)[1];
1460     SV **namepad = AvARRAY(comppad_name);
1461     SV **curpad = AvARRAY(comppad);
1462     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1463         SV *namesv = namepad[ix];
1464         if (namesv && namesv != &PL_sv_undef
1465             && *SvPVX(namesv) == '&')
1466         {
1467             CV *innercv = (CV*)curpad[ix];
1468             assert(CvWEAKOUTSIDE(innercv));
1469             assert(CvOUTSIDE(innercv) == old_cv);
1470             CvOUTSIDE(innercv) = new_cv;
1471         }
1472     }
1473 }
1474
1475
1476 /*
1477 =for apidoc pad_push
1478
1479 Push a new pad frame onto the padlist, unless there's already a pad at
1480 this depth, in which case don't bother creating a new one.
1481 If has_args is true, give the new pad an @_ in slot zero.
1482
1483 =cut
1484 */
1485
1486 void
1487 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1488 {
1489     if (depth <= AvFILLp(padlist))
1490         return;
1491
1492     {
1493         SV** svp = AvARRAY(padlist);
1494         AV *newpad = newAV();
1495         SV **oldpad = AvARRAY(svp[depth-1]);
1496         I32 ix = AvFILLp((AV*)svp[1]);
1497         I32 names_fill = AvFILLp((AV*)svp[0]);
1498         SV** names = AvARRAY(svp[0]);
1499         SV* sv;
1500         for ( ;ix > 0; ix--) {
1501             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1502                 char *name = SvPVX(names[ix]);
1503                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1504                     /* outer lexical or anon code */
1505                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1506                 }
1507                 else {          /* our own lexical */
1508                     if (*name == '@')
1509                         av_store(newpad, ix, sv = (SV*)newAV());
1510                     else if (*name == '%')
1511                         av_store(newpad, ix, sv = (SV*)newHV());
1512                     else
1513                         av_store(newpad, ix, sv = NEWSV(0, 0));
1514                     SvPADMY_on(sv);
1515                 }
1516             }
1517             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1518                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1519             }
1520             else {
1521                 /* save temporaries on recursion? */
1522                 av_store(newpad, ix, sv = NEWSV(0, 0));
1523                 SvPADTMP_on(sv);
1524             }
1525         }
1526         if (has_args) {
1527             AV* av = newAV();
1528             av_extend(av, 0);
1529             av_store(newpad, 0, (SV*)av);
1530             AvFLAGS(av) = AVf_REIFY;
1531         }
1532         av_store(padlist, depth, (SV*)newpad);
1533         AvFILLp(padlist) = depth;
1534     }
1535 }