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