3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "Anyway: there was this Mr Frodo left an orphan and stranded, as you
10 * might say, among those queer Bucklanders, being brought up anyhow in
11 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
12 * never had fewer than a couple of hundred relations in the place. Mr
13 * Bilbo never did a kinder deed than when he brought the lad back to
14 * live among decent folk." --the Gaffer
18 * As of Sept 2002, this file is new and may be in a state of flux for
19 * a while. I've marked things I intent to come back and look at further
20 * with an 'XXX DAPM' comment.
24 =head1 Pad Data Structures
26 This file contains the functions that create and manipulate scratchpads,
27 which are array-of-array data structures attached to a CV (ie a sub)
28 and which store lexical variables and opcode temporary and per-thread
31 =for apidoc m|AV *|CvPADLIST|CV *cv
32 CV's can have CvPADLIST(cv) set to point to an AV.
34 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
35 not callable at will and are always thrown away after the eval"" is done
36 executing). Require'd files are simply evals without any outer lexical
39 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
40 but that is really the callers pad (a slot of which is allocated by
43 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
44 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
45 The items in the AV are not SVs as for a normal AV, but other AVs:
47 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
48 the "static type information" for lexicals.
50 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
51 depth of recursion into the CV.
52 The 0'th slot of a frame AV is an AV which is @_.
53 other entries are storage for variables and op targets.
56 C<PL_comppad_name> is set to the names AV.
57 C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
58 C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
60 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
61 frame of the currently executing sub.
63 Iterating over the names AV iterates over all possible pad
64 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
65 &PL_sv_undef "names" (see pad_alloc()).
67 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
68 The rest are op targets/GVs/constants which are statically allocated
69 or resolved at compile time. These don't have names by which they
70 can be looked up from Perl code at run time through eval"" like
71 my/our variables can be. Since they can't be looked up by "name"
72 but only by their index allocated at compile time (which is usually
73 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
75 The SVs in the names AV have their PV being the name of the variable.
76 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
77 which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
78 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
79 SvOURSTASH slot pointing at the stash of the associated global (so that
80 duplicate C<our> declarations in the same package can be detected). SvUVX is
81 sometimes hijacked to store the generation number during compilation.
83 If SvFAKE is set on the name SV, then that slot in the frame AV is
84 a REFCNT'ed reference to a lexical from "outside". In this case,
85 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
86 in scope throughout. Instead xhigh stores some flags containing info about
87 the real lexical (is it declared in an anon, and is it capable of being
88 instantiated multiple times?), and for fake ANONs, xlow contains the index
89 within the parent's pad where the lexical's value is stored, to make
92 If the 'name' is '&' the corresponding entry in frame AV
93 is a CV representing a possible closure.
94 (SvFAKE and name of '&' is not a meaningful combination currently but could
95 become so if C<my sub foo {}> is implemented.)
97 Note that formats are treated as anon subs, and are cloned each time
98 write is called (if necessary).
100 The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
101 and set on scope exit. This allows the 'Variable $x is not available' warning
102 to be generated in evals, such as
104 { my $x = 1; sub f { eval '$x'} } f();
106 For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
113 #define PERL_IN_PAD_C
115 #include "keywords.h"
117 #define COP_SEQ_RANGE_LOW_set(sv,val) \
118 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
119 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
120 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
122 #define PARENT_PAD_INDEX_set(sv,val) \
123 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
124 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
125 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
127 #define PAD_MAX I32_MAX
130 void pad_peg(const char* s) {
133 PERL_ARGS_ASSERT_PAD_PEG;
142 Create a new compiling padlist, saving and updating the various global
143 vars at the same time as creating the pad itself. The following flags
144 can be OR'ed together:
146 padnew_CLONE this pad is for a cloned CV
147 padnew_SAVE save old globals
148 padnew_SAVESUB also save extra stuff for start of sub
154 Perl_pad_new(pTHX_ int flags)
157 AV *padlist, *padname, *pad;
159 ASSERT_CURPAD_LEGAL("pad_new");
161 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
162 * vars (based on flags) rather than storing vals + addresses for
163 * each individually. Also see pad_block_start.
164 * XXX DAPM Try to see whether all these conditionals are required
167 /* save existing state, ... */
169 if (flags & padnew_SAVE) {
171 SAVESPTR(PL_comppad_name);
172 if (! (flags & padnew_CLONE)) {
174 SAVEI32(PL_comppad_name_fill);
175 SAVEI32(PL_min_intro_pending);
176 SAVEI32(PL_max_intro_pending);
177 SAVEBOOL(PL_cv_has_eval);
178 if (flags & padnew_SAVESUB) {
179 SAVEI32(PL_pad_reset_pending);
183 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
184 * saved - check at some pt that this is okay */
186 /* ... create new pad ... */
192 if (flags & padnew_CLONE) {
193 /* XXX DAPM I dont know why cv_clone needs it
194 * doing differently yet - perhaps this separate branch can be
195 * dispensed with eventually ???
198 AV * const a0 = newAV(); /* will be @_ */
200 av_store(pad, 0, MUTABLE_SV(a0));
204 av_store(pad, 0, NULL);
208 av_store(padlist, 0, MUTABLE_SV(padname));
209 av_store(padlist, 1, MUTABLE_SV(pad));
211 /* ... then update state variables */
213 PL_comppad_name = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
214 PL_comppad = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));
215 PL_curpad = AvARRAY(PL_comppad);
217 if (! (flags & padnew_CLONE)) {
218 PL_comppad_name_fill = 0;
219 PL_min_intro_pending = 0;
224 DEBUG_X(PerlIO_printf(Perl_debug_log,
225 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
226 " name=0x%"UVxf" flags=0x%"UVxf"\n",
227 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
228 PTR2UV(padname), (UV)flags
232 return (PADLIST*)padlist;
236 =for apidoc pad_undef
238 Free the padlist associated with a CV.
239 If parts of it happen to be current, we null the relevant
240 PL_*pad* global vars so that we don't have any dangling references left.
241 We also repoint the CvOUTSIDE of any about-to-be-orphaned
242 inner subs to the outer of this cv.
244 (This function should really be called pad_free, but the name was already
251 Perl_pad_undef(pTHX_ CV* cv)
255 const PADLIST * const padlist = CvPADLIST(cv);
257 PERL_ARGS_ASSERT_PAD_UNDEF;
259 pad_peg("pad_undef");
262 if (SvIS_FREED(padlist)) /* may be during global destruction */
265 DEBUG_X(PerlIO_printf(Perl_debug_log,
266 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
267 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
270 /* detach any '&' anon children in the pad; if afterwards they
271 * are still live, fix up their CvOUTSIDEs to point to our outside,
273 /* XXX DAPM for efficiency, we should only do this if we know we have
274 * children, or integrate this loop with general cleanup */
276 if (!PL_dirty) { /* don't bother during global destruction */
277 CV * const outercv = CvOUTSIDE(cv);
278 const U32 seq = CvOUTSIDE_SEQ(cv);
279 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
280 SV ** const namepad = AvARRAY(comppad_name);
281 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
282 SV ** const curpad = AvARRAY(comppad);
283 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
284 SV * const namesv = namepad[ix];
285 if (namesv && namesv != &PL_sv_undef
286 && *SvPVX_const(namesv) == '&')
288 CV * const innercv = MUTABLE_CV(curpad[ix]);
289 U32 inner_rc = SvREFCNT(innercv);
292 SvREFCNT_dec(namesv);
294 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
296 SvREFCNT_dec(innercv);
300 /* in use, not just a prototype */
301 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
302 assert(CvWEAKOUTSIDE(innercv));
303 /* don't relink to grandfather if he's being freed */
304 if (outercv && SvREFCNT(outercv)) {
305 CvWEAKOUTSIDE_off(innercv);
306 CvOUTSIDE(innercv) = outercv;
307 CvOUTSIDE_SEQ(innercv) = seq;
308 SvREFCNT_inc_simple_void_NN(outercv);
311 CvOUTSIDE(innercv) = NULL;
318 ix = AvFILLp(padlist);
320 SV* const sv = AvARRAY(padlist)[ix--];
322 if (sv == (const SV *)PL_comppad_name)
323 PL_comppad_name = NULL;
324 else if (sv == (const SV *)PL_comppad) {
331 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
332 CvPADLIST(cv) = NULL;
339 =for apidoc pad_add_name
341 Create a new name and associated PADMY SV in the current pad; return the
343 If C<typestash> is valid, the name is for a typed lexical; set the
344 name's stash to that value.
345 If C<ourstash> is valid, it's an our lexical, set the name's
346 SvOURSTASH to that value
348 If fake, it means we're cloning an existing entry
354 Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
357 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
359 = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
361 PERL_ARGS_ASSERT_PAD_ADD_NAME;
363 ASSERT_CURPAD_ACTIVE("pad_add_name");
365 sv_setpv(namesv, name);
368 assert(SvTYPE(namesv) == SVt_PVMG);
369 SvPAD_TYPED_on(namesv);
370 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
373 SvPAD_OUR_on(namesv);
374 SvOURSTASH_set(namesv, ourstash);
375 SvREFCNT_inc_simple_void_NN(ourstash);
378 SvPAD_STATE_on(namesv);
381 av_store(PL_comppad_name, offset, namesv);
384 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
385 "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
388 /* not yet introduced */
389 COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
390 COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
392 if (!PL_min_intro_pending)
393 PL_min_intro_pending = offset;
394 PL_max_intro_pending = offset;
395 /* if it's not a simple scalar, replace with an AV or HV */
396 /* XXX DAPM since slot has been allocated, replace
397 * av_store with PL_curpad[offset] ? */
399 av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
400 else if (*name == '%')
401 av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
402 SvPADMY_on(PL_curpad[offset]);
403 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
404 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
405 (long)offset, name, PTR2UV(PL_curpad[offset])));
415 =for apidoc pad_alloc
417 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
418 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
419 for a slot which has no name and no active value.
424 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
425 * or at least rationalise ??? */
426 /* And flag whether the incoming name is UTF8 or 8 bit?
427 Could do this either with the +ve/-ve hack of the HV code, or expanding
428 the flag bits. Either way, this makes proper Unicode safe pad support.
433 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
439 PERL_UNUSED_ARG(optype);
440 ASSERT_CURPAD_ACTIVE("pad_alloc");
442 if (AvARRAY(PL_comppad) != PL_curpad)
443 Perl_croak(aTHX_ "panic: pad_alloc");
444 if (PL_pad_reset_pending)
446 if (tmptype & SVs_PADMY) {
447 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
448 retval = AvFILLp(PL_comppad);
451 SV * const * const names = AvARRAY(PL_comppad_name);
452 const SSize_t names_fill = AvFILLp(PL_comppad_name);
455 * "foreach" index vars temporarily become aliases to non-"my"
456 * values. Thus we must skip, not just pad values that are
457 * marked as current pad values, but also those with names.
459 /* HVDS why copy to sv here? we don't seem to use it */
460 if (++PL_padix <= names_fill &&
461 (sv = names[PL_padix]) && sv != &PL_sv_undef)
463 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
464 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
465 !IS_PADGV(sv) && !IS_PADCONST(sv))
470 SvFLAGS(sv) |= tmptype;
471 PL_curpad = AvARRAY(PL_comppad);
473 DEBUG_X(PerlIO_printf(Perl_debug_log,
474 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
475 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
476 PL_op_name[optype]));
477 #ifdef DEBUG_LEAKING_SCALARS
478 sv->sv_debug_optype = optype;
479 sv->sv_debug_inpad = 1;
481 return (PADOFFSET)retval;
485 =for apidoc pad_add_anon
487 Add an anon code entry to the current compiling pad
493 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
497 SV* const name = newSV_type(SVt_PVNV);
499 PERL_ARGS_ASSERT_PAD_ADD_ANON;
502 sv_setpvs(name, "&");
503 /* Are these two actually ever read? */
504 COP_SEQ_RANGE_HIGH_set(name, ~0);
505 COP_SEQ_RANGE_LOW_set(name, 1);
506 ix = pad_alloc(op_type, SVs_PADMY);
507 av_store(PL_comppad_name, ix, name);
508 /* XXX DAPM use PL_curpad[] ? */
509 av_store(PL_comppad, ix, sv);
512 /* to avoid ref loops, we never have parent + child referencing each
513 * other simultaneously */
514 if (CvOUTSIDE((const CV *)sv)) {
515 assert(!CvWEAKOUTSIDE((const CV *)sv));
516 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
517 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
525 =for apidoc pad_check_dup
527 Check for duplicate declarations: report any of:
528 * a my in the current scope with the same name;
529 * an our (anywhere in the pad) with the same name and the same stash
531 C<is_our> indicates that the name to check is an 'our' declaration
536 /* XXX DAPM integrate this into pad_add_name ??? */
539 Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
545 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
547 ASSERT_CURPAD_ACTIVE("pad_check_dup");
548 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
549 return; /* nothing to check */
551 svp = AvARRAY(PL_comppad_name);
552 top = AvFILLp(PL_comppad_name);
553 /* check the current scope */
554 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
556 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
557 SV * const sv = svp[off];
559 && sv != &PL_sv_undef
561 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
562 && strEQ(name, SvPVX_const(sv)))
564 if (is_our && (SvPAD_OUR(sv)))
565 break; /* "our" masking "our" */
566 Perl_warner(aTHX_ packWARN(WARN_MISC),
567 "\"%s\" variable %s masks earlier declaration in same %s",
568 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
570 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
575 /* check the rest of the pad */
578 SV * const sv = svp[off];
580 && sv != &PL_sv_undef
582 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
583 && SvOURSTASH(sv) == ourstash
584 && strEQ(name, SvPVX_const(sv)))
586 Perl_warner(aTHX_ packWARN(WARN_MISC),
587 "\"our\" variable %s redeclared", name);
588 if ((I32)off <= PL_comppad_name_floor)
589 Perl_warner(aTHX_ packWARN(WARN_MISC),
590 "\t(Did you mean \"local\" instead of \"our\"?)\n");
593 } while ( off-- > 0 );
599 =for apidoc pad_findmy
601 Given a lexical name, try to find its offset, first in the current pad,
602 or failing that, in the pads of any lexically enclosing subs (including
603 the complications introduced by eval). If the name is found in an outer pad,
604 then a fake entry is added to the current pad.
605 Returns the offset in the current pad, or NOT_IN_PAD on failure.
611 Perl_pad_findmy(pTHX_ const char *name)
620 PERL_ARGS_ASSERT_PAD_FINDMY;
622 pad_peg("pad_findmy");
623 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
624 NULL, &out_sv, &out_flags);
625 if ((PADOFFSET)offset != NOT_IN_PAD)
628 /* look for an our that's being introduced; this allows
629 * our $foo = 0 unless defined $foo;
630 * to not give a warning. (Yes, this is a hack) */
632 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
633 name_svp = AvARRAY(nameav);
634 for (offset = AvFILLp(nameav); offset > 0; offset--) {
635 const SV * const namesv = name_svp[offset];
636 if (namesv && namesv != &PL_sv_undef
638 && (SvPAD_OUR(namesv))
639 && strEQ(SvPVX_const(namesv), name)
640 && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
648 * Returns the offset of a lexical $_, if there is one, at run time.
649 * Used by the UNDERBAR XS macro.
653 Perl_find_rundefsvoffset(pTHX)
658 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
659 NULL, &out_sv, &out_flags);
663 =for apidoc pad_findlex
665 Find a named lexical anywhere in a chain of nested pads. Add fake entries
666 in the inner pads if it's found in an outer one.
668 Returns the offset in the bottom pad of the lex or the fake lex.
669 cv is the CV in which to start the search, and seq is the current cop_seq
670 to match against. If warn is true, print appropriate warnings. The out_*
671 vars return values, and so are pointers to where the returned values
672 should be stored. out_capture, if non-null, requests that the innermost
673 instance of the lexical is captured; out_name_sv is set to the innermost
674 matched namesv or fake namesv; out_flags returns the flags normally
675 associated with the IVX field of a fake namesv.
677 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
678 then comes back down, adding fake entries as it goes. It has to be this way
679 because fake namesvs in anon protoypes have to store in xlow the index into
685 /* the CV has finished being compiled. This is not a sufficient test for
686 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
687 #define CvCOMPILED(cv) CvROOT(cv)
689 /* the CV does late binding of its lexicals */
690 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
694 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
695 SV** out_capture, SV** out_name_sv, int *out_flags)
698 I32 offset, new_offset;
701 const AV * const padlist = CvPADLIST(cv);
703 PERL_ARGS_ASSERT_PAD_FINDLEX;
707 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
708 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
709 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
711 /* first, search this pad */
713 if (padlist) { /* not an undef CV */
715 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
716 SV * const * const name_svp = AvARRAY(nameav);
718 for (offset = AvFILLp(nameav); offset > 0; offset--) {
719 const SV * const namesv = name_svp[offset];
720 if (namesv && namesv != &PL_sv_undef
721 && strEQ(SvPVX_const(namesv), name))
724 fake_offset = offset; /* in case we don't find a real one */
725 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
726 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
731 if (offset > 0 || fake_offset > 0 ) { /* a match! */
732 if (offset > 0) { /* not fake */
734 *out_name_sv = name_svp[offset]; /* return the namesv */
736 /* set PAD_FAKELEX_MULTI if this lex can have multiple
737 * instances. For now, we just test !CvUNIQUE(cv), but
738 * ideally, we should detect my's declared within loops
739 * etc - this would allow a wider range of 'not stayed
740 * shared' warnings. We also treated alreadly-compiled
741 * lexes as not multi as viewed from evals. */
743 *out_flags = CvANON(cv) ?
745 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
746 ? PAD_FAKELEX_MULTI : 0;
748 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
749 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
750 PTR2UV(cv), (long)offset,
751 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
752 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
754 else { /* fake match */
755 offset = fake_offset;
756 *out_name_sv = name_svp[offset]; /* return the namesv */
757 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
758 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
759 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
760 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
761 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
765 /* return the lex? */
770 if (SvPAD_OUR(*out_name_sv)) {
775 /* trying to capture from an anon prototype? */
777 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
778 : *out_flags & PAD_FAKELEX_ANON)
780 if (warn && ckWARN(WARN_CLOSURE))
781 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
782 "Variable \"%s\" is not available", name);
789 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
790 && !SvPAD_STATE(name_svp[offset])
791 && warn && ckWARN(WARN_CLOSURE)) {
793 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
794 "Variable \"%s\" will not stay shared", name);
797 if (fake_offset && CvANON(cv)
798 && CvCLONE(cv) &&!CvCLONED(cv))
801 /* not yet caught - look further up */
802 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
803 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
806 (void) pad_findlex(name, CvOUTSIDE(cv),
808 newwarn, out_capture, out_name_sv, out_flags);
813 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
814 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
815 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
816 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
817 PTR2UV(cv), PTR2UV(*out_capture)));
819 if (SvPADSTALE(*out_capture)
820 && !SvPAD_STATE(name_svp[offset]))
822 if (ckWARN(WARN_CLOSURE))
823 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
824 "Variable \"%s\" is not available", name);
830 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
831 else if (*name == '%')
832 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
834 *out_capture = sv_newmortal();
842 /* it's not in this pad - try above */
847 /* out_capture non-null means caller wants us to capture lex; in
848 * addition we capture ourselves unless it's an ANON/format */
849 new_capturep = out_capture ? out_capture :
850 CvLATE(cv) ? NULL : &new_capture;
852 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
853 new_capturep, out_name_sv, out_flags);
854 if ((PADOFFSET)offset == NOT_IN_PAD)
857 /* found in an outer CV. Add appropriate fake entry to this pad */
859 /* don't add new fake entries (via eval) to CVs that we have already
860 * finished compiling, or to undef CVs */
861 if (CvCOMPILED(cv) || !padlist)
862 return 0; /* this dummy (and invalid) value isnt used by the caller */
866 AV * const ocomppad_name = PL_comppad_name;
867 PAD * const ocomppad = PL_comppad;
868 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
869 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
870 PL_curpad = AvARRAY(PL_comppad);
872 new_offset = pad_add_name(
873 SvPVX_const(*out_name_sv),
874 SvPAD_TYPED(*out_name_sv)
875 ? SvSTASH(*out_name_sv) : NULL,
876 SvOURSTASH(*out_name_sv),
878 SvPAD_STATE(*out_name_sv) ? 1 : 0 /* state variable ? */
881 new_namesv = AvARRAY(PL_comppad_name)[new_offset];
882 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
884 PARENT_PAD_INDEX_set(new_namesv, 0);
885 if (SvPAD_OUR(new_namesv)) {
886 NOOP; /* do nothing */
888 else if (CvLATE(cv)) {
889 /* delayed creation - just note the offset within parent pad */
890 PARENT_PAD_INDEX_set(new_namesv, offset);
894 /* immediate creation - capture outer value right now */
895 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
896 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
897 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
898 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
900 *out_name_sv = new_namesv;
901 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
903 PL_comppad_name = ocomppad_name;
904 PL_comppad = ocomppad;
905 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
915 Get the value at offset po in the current pad.
916 Use macro PAD_SV instead of calling this function directly.
923 Perl_pad_sv(pTHX_ PADOFFSET po)
926 ASSERT_CURPAD_ACTIVE("pad_sv");
929 Perl_croak(aTHX_ "panic: pad_sv po");
930 DEBUG_X(PerlIO_printf(Perl_debug_log,
931 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
932 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
934 return PL_curpad[po];
939 =for apidoc pad_setsv
941 Set the entry at offset po in the current pad to sv.
942 Use the macro PAD_SETSV() rather than calling this function directly.
948 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
952 PERL_ARGS_ASSERT_PAD_SETSV;
954 ASSERT_CURPAD_ACTIVE("pad_setsv");
956 DEBUG_X(PerlIO_printf(Perl_debug_log,
957 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
958 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
967 =for apidoc pad_block_start
969 Update the pad compilation state variables on entry to a new block
975 * - integrate this in general state-saving routine ???
976 * - combine with the state-saving going on in pad_new ???
977 * - introduce a new SAVE type that does all this in one go ?
981 Perl_pad_block_start(pTHX_ int full)
984 ASSERT_CURPAD_ACTIVE("pad_block_start");
985 SAVEI32(PL_comppad_name_floor);
986 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
988 PL_comppad_name_fill = PL_comppad_name_floor;
989 if (PL_comppad_name_floor < 0)
990 PL_comppad_name_floor = 0;
991 SAVEI32(PL_min_intro_pending);
992 SAVEI32(PL_max_intro_pending);
993 PL_min_intro_pending = 0;
994 SAVEI32(PL_comppad_name_fill);
995 SAVEI32(PL_padix_floor);
996 PL_padix_floor = PL_padix;
997 PL_pad_reset_pending = FALSE;
1002 =for apidoc intro_my
1004 "Introduce" my variables to visible status.
1016 ASSERT_CURPAD_ACTIVE("intro_my");
1017 if (! PL_min_intro_pending)
1018 return PL_cop_seqmax;
1020 svp = AvARRAY(PL_comppad_name);
1021 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1022 SV * const sv = svp[i];
1024 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1025 COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
1026 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1027 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1028 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1029 (long)i, SvPVX_const(sv),
1030 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1031 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1035 PL_min_intro_pending = 0;
1036 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1037 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1038 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1040 return PL_cop_seqmax++;
1044 =for apidoc pad_leavemy
1046 Cleanup at end of scope during compilation: set the max seq number for
1047 lexicals in this scope and warn of any lexicals that never got introduced.
1053 Perl_pad_leavemy(pTHX)
1057 SV * const * const svp = AvARRAY(PL_comppad_name);
1059 PL_pad_reset_pending = FALSE;
1061 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1062 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1063 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1064 const SV * const sv = svp[off];
1065 if (sv && sv != &PL_sv_undef
1066 && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
1067 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1068 "%"SVf" never introduced",
1072 /* "Deintroduce" my variables that are leaving with this scope. */
1073 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1074 const SV * const sv = svp[off];
1075 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1076 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1077 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1078 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1079 (long)off, SvPVX_const(sv),
1080 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1081 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1086 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1087 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1092 =for apidoc pad_swipe
1094 Abandon the tmp in the current pad at offset po and replace with a
1101 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1104 ASSERT_CURPAD_LEGAL("pad_swipe");
1107 if (AvARRAY(PL_comppad) != PL_curpad)
1108 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1110 Perl_croak(aTHX_ "panic: pad_swipe po");
1112 DEBUG_X(PerlIO_printf(Perl_debug_log,
1113 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1114 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1117 SvPADTMP_off(PL_curpad[po]);
1119 SvREFCNT_dec(PL_curpad[po]);
1122 /* if pad tmps aren't shared between ops, then there's no need to
1123 * create a new tmp when an existing op is freed */
1124 #ifdef USE_BROKEN_PAD_RESET
1125 PL_curpad[po] = newSV(0);
1126 SvPADTMP_on(PL_curpad[po]);
1128 PL_curpad[po] = &PL_sv_undef;
1130 if ((I32)po < PL_padix)
1136 =for apidoc pad_reset
1138 Mark all the current temporaries for reuse
1143 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1144 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1145 * on the stack by OPs that use them, there are several ways to get an alias
1146 * to a shared TARG. Such an alias will change randomly and unpredictably.
1147 * We avoid doing this until we can think of a Better Way.
1150 Perl_pad_reset(pTHX)
1153 #ifdef USE_BROKEN_PAD_RESET
1154 if (AvARRAY(PL_comppad) != PL_curpad)
1155 Perl_croak(aTHX_ "panic: pad_reset curpad");
1157 DEBUG_X(PerlIO_printf(Perl_debug_log,
1158 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1159 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1160 (long)PL_padix, (long)PL_padix_floor
1164 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1166 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1167 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1168 SvPADTMP_off(PL_curpad[po]);
1170 PL_padix = PL_padix_floor;
1173 PL_pad_reset_pending = FALSE;
1178 =for apidoc pad_tidy
1180 Tidy up a pad after we've finished compiling it:
1181 * remove most stuff from the pads of anonsub prototypes;
1183 * mark tmps as such.
1188 /* XXX DAPM surely most of this stuff should be done properly
1189 * at the right time beforehand, rather than going around afterwards
1190 * cleaning up our mistakes ???
1194 Perl_pad_tidy(pTHX_ padtidy_type type)
1198 ASSERT_CURPAD_ACTIVE("pad_tidy");
1200 /* If this CV has had any 'eval-capable' ops planted in it
1201 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1202 * anon prototypes in the chain of CVs should be marked as cloneable,
1203 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1204 * the right CvOUTSIDE.
1205 * If running with -d, *any* sub may potentially have an eval
1206 * excuted within it.
1209 if (PL_cv_has_eval || PL_perldb) {
1211 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1212 if (cv != PL_compcv && CvCOMPILED(cv))
1213 break; /* no need to mark already-compiled code */
1215 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1216 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1222 /* extend curpad to match namepad */
1223 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1224 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1226 if (type == padtidy_SUBCLONE) {
1227 SV * const * const namep = AvARRAY(PL_comppad_name);
1230 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1233 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1236 * The only things that a clonable function needs in its
1237 * pad are anonymous subs.
1238 * The rest are created anew during cloning.
1240 if (!((namesv = namep[ix]) != NULL &&
1241 namesv != &PL_sv_undef &&
1242 *SvPVX_const(namesv) == '&'))
1244 SvREFCNT_dec(PL_curpad[ix]);
1245 PL_curpad[ix] = NULL;
1249 else if (type == padtidy_SUB) {
1250 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1251 AV * const av = newAV(); /* Will be @_ */
1253 av_store(PL_comppad, 0, MUTABLE_SV(av));
1257 /* XXX DAPM rationalise these two similar branches */
1259 if (type == padtidy_SUB) {
1261 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1262 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1264 if (!SvPADMY(PL_curpad[ix]))
1265 SvPADTMP_on(PL_curpad[ix]);
1268 else if (type == padtidy_FORMAT) {
1270 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1271 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1272 SvPADTMP_on(PL_curpad[ix]);
1275 PL_curpad = AvARRAY(PL_comppad);
1280 =for apidoc pad_free
1282 Free the SV at offset po in the current pad.
1287 /* XXX DAPM integrate with pad_swipe ???? */
1289 Perl_pad_free(pTHX_ PADOFFSET po)
1292 ASSERT_CURPAD_LEGAL("pad_free");
1295 if (AvARRAY(PL_comppad) != PL_curpad)
1296 Perl_croak(aTHX_ "panic: pad_free curpad");
1298 Perl_croak(aTHX_ "panic: pad_free po");
1300 DEBUG_X(PerlIO_printf(Perl_debug_log,
1301 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1302 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1305 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1306 SvPADTMP_off(PL_curpad[po]);
1308 /* SV could be a shared hash key (eg bugid #19022) */
1310 #ifdef PERL_OLD_COPY_ON_WRITE
1311 !SvIsCOW(PL_curpad[po])
1313 !SvFAKE(PL_curpad[po])
1316 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1319 if ((I32)po < PL_padix)
1326 =for apidoc do_dump_pad
1328 Dump the contents of a padlist
1334 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1343 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1348 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1349 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1350 pname = AvARRAY(pad_name);
1351 ppad = AvARRAY(pad);
1352 Perl_dump_indent(aTHX_ level, file,
1353 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1354 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1357 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1358 const SV *namesv = pname[ix];
1359 if (namesv && namesv == &PL_sv_undef) {
1364 Perl_dump_indent(aTHX_ level+1, file,
1365 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1368 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1369 SvPVX_const(namesv),
1370 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1371 (unsigned long)PARENT_PAD_INDEX(namesv)
1375 Perl_dump_indent(aTHX_ level+1, file,
1376 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1379 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1380 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1381 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1386 Perl_dump_indent(aTHX_ level+1, file,
1387 "%2d. 0x%"UVxf"<%lu>\n",
1390 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1401 dump the contents of a CV
1408 S_cv_dump(pTHX_ const CV *cv, const char *title)
1411 const CV * const outside = CvOUTSIDE(cv);
1412 AV* const padlist = CvPADLIST(cv);
1414 PERL_ARGS_ASSERT_CV_DUMP;
1416 PerlIO_printf(Perl_debug_log,
1417 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1420 (CvANON(cv) ? "ANON"
1421 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1422 : (cv == PL_main_cv) ? "MAIN"
1423 : CvUNIQUE(cv) ? "UNIQUE"
1424 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1427 : CvANON(outside) ? "ANON"
1428 : (outside == PL_main_cv) ? "MAIN"
1429 : CvUNIQUE(outside) ? "UNIQUE"
1430 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1432 PerlIO_printf(Perl_debug_log,
1433 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1434 do_dump_pad(1, Perl_debug_log, padlist, 1);
1436 #endif /* DEBUGGING */
1443 =for apidoc cv_clone
1445 Clone a CV: make a new CV which points to the same code etc, but which
1446 has a newly-created pad built by copying the prototype pad and capturing
1453 Perl_cv_clone(pTHX_ CV *proto)
1457 AV* const protopadlist = CvPADLIST(proto);
1458 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1459 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1460 SV** const pname = AvARRAY(protopad_name);
1461 SV** const ppad = AvARRAY(protopad);
1462 const I32 fname = AvFILLp(protopad_name);
1463 const I32 fpad = AvFILLp(protopad);
1469 PERL_ARGS_ASSERT_CV_CLONE;
1471 assert(!CvUNIQUE(proto));
1473 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1474 * to a prototype; we instead want the cloned parent who called us.
1475 * Note that in general for formats, CvOUTSIDE != find_runcv */
1477 outside = CvOUTSIDE(proto);
1478 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1479 outside = find_runcv(NULL);
1480 depth = CvDEPTH(outside);
1481 assert(depth || SvTYPE(proto) == SVt_PVFM);
1484 assert(CvPADLIST(outside));
1487 SAVESPTR(PL_compcv);
1489 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1490 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1494 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1495 : savepv(CvFILE(proto));
1497 CvFILE(cv) = CvFILE(proto);
1499 CvGV(cv) = CvGV(proto);
1500 CvSTASH(cv) = CvSTASH(proto);
1502 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1504 CvSTART(cv) = CvSTART(proto);
1505 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1506 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1509 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1511 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1513 av_fill(PL_comppad, fpad);
1514 for (ix = fname; ix >= 0; ix--)
1515 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1517 PL_curpad = AvARRAY(PL_comppad);
1519 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1521 for (ix = fpad; ix > 0; ix--) {
1522 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1524 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1525 if (SvFAKE(namesv)) { /* lexical from outside? */
1526 sv = outpad[PARENT_PAD_INDEX(namesv)];
1528 /* formats may have an inactive parent,
1529 while my $x if $false can leave an active var marked as
1530 stale. And state vars are always available */
1531 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1532 if (ckWARN(WARN_CLOSURE))
1533 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1534 "Variable \"%s\" is not available", SvPVX_const(namesv));
1538 SvREFCNT_inc_simple_void_NN(sv);
1541 const char sigil = SvPVX_const(namesv)[0];
1543 sv = SvREFCNT_inc(ppad[ix]);
1544 else if (sigil == '@')
1545 sv = MUTABLE_SV(newAV());
1546 else if (sigil == '%')
1547 sv = MUTABLE_SV(newHV());
1551 /* reset the 'assign only once' flag on each state var */
1552 if (SvPAD_STATE(namesv))
1556 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1557 sv = SvREFCNT_inc_NN(ppad[ix]);
1567 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1568 cv_dump(outside, "Outside");
1569 cv_dump(proto, "Proto");
1576 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1577 * The prototype was marked as a candiate for const-ization,
1578 * so try to grab the current const value, and if successful,
1579 * turn into a const sub:
1581 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1584 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1596 =for apidoc pad_fixup_inner_anons
1598 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1599 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1600 moved to a pre-existing CV struct.
1606 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1610 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1611 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1612 SV ** const namepad = AvARRAY(comppad_name);
1613 SV ** const curpad = AvARRAY(comppad);
1615 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1616 PERL_UNUSED_ARG(old_cv);
1618 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1619 const SV * const namesv = namepad[ix];
1620 if (namesv && namesv != &PL_sv_undef
1621 && *SvPVX_const(namesv) == '&')
1623 CV * const innercv = MUTABLE_CV(curpad[ix]);
1624 assert(CvWEAKOUTSIDE(innercv));
1625 assert(CvOUTSIDE(innercv) == old_cv);
1626 CvOUTSIDE(innercv) = new_cv;
1633 =for apidoc pad_push
1635 Push a new pad frame onto the padlist, unless there's already a pad at
1636 this depth, in which case don't bother creating a new one. Then give
1637 the new pad an @_ in slot zero.
1643 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1647 PERL_ARGS_ASSERT_PAD_PUSH;
1649 if (depth > AvFILLp(padlist)) {
1650 SV** const svp = AvARRAY(padlist);
1651 AV* const newpad = newAV();
1652 SV** const oldpad = AvARRAY(svp[depth-1]);
1653 I32 ix = AvFILLp((const AV *)svp[1]);
1654 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1655 SV** const names = AvARRAY(svp[0]);
1658 for ( ;ix > 0; ix--) {
1659 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1660 const char sigil = SvPVX_const(names[ix])[0];
1661 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1662 || (SvFLAGS(names[ix]) & SVpad_STATE)
1665 /* outer lexical or anon code */
1666 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1668 else { /* our own lexical */
1671 sv = MUTABLE_SV(newAV());
1672 else if (sigil == '%')
1673 sv = MUTABLE_SV(newHV());
1676 av_store(newpad, ix, sv);
1680 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1681 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1684 /* save temporaries on recursion? */
1685 SV * const sv = newSV(0);
1686 av_store(newpad, ix, sv);
1692 av_store(newpad, 0, MUTABLE_SV(av));
1695 av_store(padlist, depth, MUTABLE_SV(newpad));
1696 AvFILLp(padlist) = depth;
1702 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1705 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1706 if ( SvPAD_TYPED(*av) ) {
1707 return SvSTASH(*av);
1714 * c-indentation-style: bsd
1716 * indent-tabs-mode: t
1719 * ex: set ts=8 sts=4 sw=4 noet: