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.
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 * As of Sept 2002, this file is new and may be in a state of flux for
23 * a while. I've marked things I intent to come back and look at further
24 * with an 'XXX DAPM' comment.
28 =head1 Pad Data Structures
30 This file contains the functions that create and manipulate scratchpads,
31 which are array-of-array data structures attached to a CV (ie a sub)
32 and which store lexical variables and opcode temporary and per-thread
35 =for apidoc m|AV *|CvPADLIST|CV *cv
36 CV's can have CvPADLIST(cv) set to point to an AV.
38 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
39 not callable at will and are always thrown away after the eval"" is done
40 executing). Require'd files are simply evals without any outer lexical
43 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
44 but that is really the callers pad (a slot of which is allocated by
47 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
48 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
49 The items in the AV are not SVs as for a normal AV, but other AVs:
51 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
52 the "static type information" for lexicals.
54 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
55 depth of recursion into the CV.
56 The 0'th slot of a frame AV is an AV which is @_.
57 other entries are storage for variables and op targets.
60 C<PL_comppad_name> is set to the names AV.
61 C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
62 C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
64 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
65 frame of the currently executing sub.
67 Iterating over the names AV iterates over all possible pad
68 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
69 &PL_sv_undef "names" (see pad_alloc()).
71 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
72 The rest are op targets/GVs/constants which are statically allocated
73 or resolved at compile time. These don't have names by which they
74 can be looked up from Perl code at run time through eval"" like
75 my/our variables can be. Since they can't be looked up by "name"
76 but only by their index allocated at compile time (which is usually
77 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
79 The SVs in the names AV have their PV being the name of the variable.
80 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
81 which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
82 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
83 SvOURSTASH slot pointing at the stash of the associated global (so that
84 duplicate C<our> declarations in the same package can be detected). SvUVX is
85 sometimes hijacked to store the generation number during compilation.
87 If SvFAKE is set on the name SV, then that slot in the frame AV is
88 a REFCNT'ed reference to a lexical from "outside". In this case,
89 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
90 in scope throughout. Instead xhigh stores some flags containing info about
91 the real lexical (is it declared in an anon, and is it capable of being
92 instantiated multiple times?), and for fake ANONs, xlow contains the index
93 within the parent's pad where the lexical's value is stored, to make
96 If the 'name' is '&' the corresponding entry in frame AV
97 is a CV representing a possible closure.
98 (SvFAKE and name of '&' is not a meaningful combination currently but could
99 become so if C<my sub foo {}> is implemented.)
101 Note that formats are treated as anon subs, and are cloned each time
102 write is called (if necessary).
104 The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
105 and set on scope exit. This allows the 'Variable $x is not available' warning
106 to be generated in evals, such as
108 { my $x = 1; sub f { eval '$x'} } f();
110 For state vars, SVf_PADSTALE is overloaded to mean 'not yet initialised'
117 #define PERL_IN_PAD_C
119 #include "keywords.h"
121 #define COP_SEQ_RANGE_LOW_set(sv,val) \
122 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
123 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
124 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
126 #define PARENT_PAD_INDEX_set(sv,val) \
127 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
128 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
129 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
131 #define PAD_MAX I32_MAX
134 void pad_peg(const char* s) {
137 PERL_ARGS_ASSERT_PAD_PEG;
146 Create a new compiling padlist, saving and updating the various global
147 vars at the same time as creating the pad itself. The following flags
148 can be OR'ed together:
150 padnew_CLONE this pad is for a cloned CV
151 padnew_SAVE save old globals
152 padnew_SAVESUB also save extra stuff for start of sub
158 Perl_pad_new(pTHX_ int flags)
161 AV *padlist, *padname, *pad;
163 ASSERT_CURPAD_LEGAL("pad_new");
165 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
166 * vars (based on flags) rather than storing vals + addresses for
167 * each individually. Also see pad_block_start.
168 * XXX DAPM Try to see whether all these conditionals are required
171 /* save existing state, ... */
173 if (flags & padnew_SAVE) {
175 SAVESPTR(PL_comppad_name);
176 if (! (flags & padnew_CLONE)) {
178 SAVEI32(PL_comppad_name_fill);
179 SAVEI32(PL_min_intro_pending);
180 SAVEI32(PL_max_intro_pending);
181 SAVEBOOL(PL_cv_has_eval);
182 if (flags & padnew_SAVESUB) {
183 SAVEBOOL(PL_pad_reset_pending);
187 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
188 * saved - check at some pt that this is okay */
190 /* ... create new pad ... */
196 if (flags & padnew_CLONE) {
197 /* XXX DAPM I dont know why cv_clone needs it
198 * doing differently yet - perhaps this separate branch can be
199 * dispensed with eventually ???
202 AV * const a0 = newAV(); /* will be @_ */
204 av_store(pad, 0, MUTABLE_SV(a0));
208 av_store(pad, 0, NULL);
212 av_store(padlist, 0, MUTABLE_SV(padname));
213 av_store(padlist, 1, MUTABLE_SV(pad));
215 /* ... then update state variables */
217 PL_comppad_name = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
218 PL_comppad = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));
219 PL_curpad = AvARRAY(PL_comppad);
221 if (! (flags & padnew_CLONE)) {
222 PL_comppad_name_fill = 0;
223 PL_min_intro_pending = 0;
228 DEBUG_X(PerlIO_printf(Perl_debug_log,
229 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
230 " name=0x%"UVxf" flags=0x%"UVxf"\n",
231 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
232 PTR2UV(padname), (UV)flags
236 return (PADLIST*)padlist;
240 =for apidoc pad_undef
242 Free the padlist associated with a CV.
243 If parts of it happen to be current, we null the relevant
244 PL_*pad* global vars so that we don't have any dangling references left.
245 We also repoint the CvOUTSIDE of any about-to-be-orphaned
246 inner subs to the outer of this cv.
248 (This function should really be called pad_free, but the name was already
255 Perl_pad_undef(pTHX_ CV* cv)
259 const PADLIST * const padlist = CvPADLIST(cv);
261 PERL_ARGS_ASSERT_PAD_UNDEF;
263 pad_peg("pad_undef");
266 if (SvIS_FREED(padlist)) /* may be during global destruction */
269 DEBUG_X(PerlIO_printf(Perl_debug_log,
270 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
271 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
274 /* detach any '&' anon children in the pad; if afterwards they
275 * are still live, fix up their CvOUTSIDEs to point to our outside,
277 /* XXX DAPM for efficiency, we should only do this if we know we have
278 * children, or integrate this loop with general cleanup */
280 if (!PL_dirty) { /* don't bother during global destruction */
281 CV * const outercv = CvOUTSIDE(cv);
282 const U32 seq = CvOUTSIDE_SEQ(cv);
283 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
284 SV ** const namepad = AvARRAY(comppad_name);
285 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
286 SV ** const curpad = AvARRAY(comppad);
287 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
288 SV * const namesv = namepad[ix];
289 if (namesv && namesv != &PL_sv_undef
290 && *SvPVX_const(namesv) == '&')
292 CV * const innercv = MUTABLE_CV(curpad[ix]);
293 U32 inner_rc = SvREFCNT(innercv);
296 SvREFCNT_dec(namesv);
298 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
300 SvREFCNT_dec(innercv);
304 /* in use, not just a prototype */
305 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
306 assert(CvWEAKOUTSIDE(innercv));
307 /* don't relink to grandfather if he's being freed */
308 if (outercv && SvREFCNT(outercv)) {
309 CvWEAKOUTSIDE_off(innercv);
310 CvOUTSIDE(innercv) = outercv;
311 CvOUTSIDE_SEQ(innercv) = seq;
312 SvREFCNT_inc_simple_void_NN(outercv);
315 CvOUTSIDE(innercv) = NULL;
322 ix = AvFILLp(padlist);
324 SV* const sv = AvARRAY(padlist)[ix--];
326 if (sv == (const SV *)PL_comppad_name)
327 PL_comppad_name = NULL;
328 else if (sv == (const SV *)PL_comppad) {
335 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
336 CvPADLIST(cv) = NULL;
343 =for apidoc pad_add_name
345 Create a new name and associated PADMY SV in the current pad; return the
347 If C<typestash> is valid, the name is for a typed lexical; set the
348 name's stash to that value.
349 If C<ourstash> is valid, it's an our lexical, set the name's
350 SvOURSTASH to that value
352 If fake, it means we're cloning an existing entry
358 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
359 HV *typestash, HV *ourstash)
362 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
365 PERL_ARGS_ASSERT_PAD_ADD_NAME;
367 ASSERT_CURPAD_ACTIVE("pad_add_name");
369 if (flags & ~(pad_add_STATE|pad_add_FAKE))
370 Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
373 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
375 /* Until we're using the length for real, cross check that we're being told
377 PERL_UNUSED_ARG(len);
378 assert(strlen(name) == len);
380 sv_setpv(namesv, name);
383 assert(SvTYPE(namesv) == SVt_PVMG);
384 SvPAD_TYPED_on(namesv);
385 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
388 SvPAD_OUR_on(namesv);
389 SvOURSTASH_set(namesv, ourstash);
390 SvREFCNT_inc_simple_void_NN(ourstash);
392 else if (flags & pad_add_STATE) {
393 SvPAD_STATE_on(namesv);
396 av_store(PL_comppad_name, offset, namesv);
397 if (flags & pad_add_FAKE) {
399 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
400 "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
403 /* not yet introduced */
404 COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
405 COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
407 if (!PL_min_intro_pending)
408 PL_min_intro_pending = offset;
409 PL_max_intro_pending = offset;
410 /* if it's not a simple scalar, replace with an AV or HV */
411 /* XXX DAPM since slot has been allocated, replace
412 * av_store with PL_curpad[offset] ? */
414 av_store(PL_comppad, offset, MUTABLE_SV(newAV()));
415 else if (*name == '%')
416 av_store(PL_comppad, offset, MUTABLE_SV(newHV()));
417 SvPADMY_on(PL_curpad[offset]);
418 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
419 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
420 (long)offset, name, PTR2UV(PL_curpad[offset])));
430 =for apidoc pad_alloc
432 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
433 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
434 for a slot which has no name and no active value.
439 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
440 * or at least rationalise ??? */
441 /* And flag whether the incoming name is UTF8 or 8 bit?
442 Could do this either with the +ve/-ve hack of the HV code, or expanding
443 the flag bits. Either way, this makes proper Unicode safe pad support.
448 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
454 PERL_UNUSED_ARG(optype);
455 ASSERT_CURPAD_ACTIVE("pad_alloc");
457 if (AvARRAY(PL_comppad) != PL_curpad)
458 Perl_croak(aTHX_ "panic: pad_alloc");
459 if (PL_pad_reset_pending)
461 if (tmptype & SVs_PADMY) {
462 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
463 retval = AvFILLp(PL_comppad);
466 SV * const * const names = AvARRAY(PL_comppad_name);
467 const SSize_t names_fill = AvFILLp(PL_comppad_name);
470 * "foreach" index vars temporarily become aliases to non-"my"
471 * values. Thus we must skip, not just pad values that are
472 * marked as current pad values, but also those with names.
474 /* HVDS why copy to sv here? we don't seem to use it */
475 if (++PL_padix <= names_fill &&
476 (sv = names[PL_padix]) && sv != &PL_sv_undef)
478 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
479 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
480 !IS_PADGV(sv) && !IS_PADCONST(sv))
485 SvFLAGS(sv) |= tmptype;
486 PL_curpad = AvARRAY(PL_comppad);
488 DEBUG_X(PerlIO_printf(Perl_debug_log,
489 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
490 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
491 PL_op_name[optype]));
492 #ifdef DEBUG_LEAKING_SCALARS
493 sv->sv_debug_optype = optype;
494 sv->sv_debug_inpad = 1;
496 return (PADOFFSET)retval;
500 =for apidoc pad_add_anon
502 Add an anon code entry to the current compiling pad
508 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
512 SV* const name = newSV_type(SVt_PVNV);
514 PERL_ARGS_ASSERT_PAD_ADD_ANON;
517 sv_setpvs(name, "&");
518 /* Are these two actually ever read? */
519 COP_SEQ_RANGE_HIGH_set(name, ~0);
520 COP_SEQ_RANGE_LOW_set(name, 1);
521 ix = pad_alloc(op_type, SVs_PADMY);
522 av_store(PL_comppad_name, ix, name);
523 /* XXX DAPM use PL_curpad[] ? */
524 av_store(PL_comppad, ix, sv);
527 /* to avoid ref loops, we never have parent + child referencing each
528 * other simultaneously */
529 if (CvOUTSIDE((const CV *)sv)) {
530 assert(!CvWEAKOUTSIDE((const CV *)sv));
531 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
532 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
540 =for apidoc pad_check_dup
542 Check for duplicate declarations: report any of:
543 * a my in the current scope with the same name;
544 * an our (anywhere in the pad) with the same name and the same stash
546 C<is_our> indicates that the name to check is an 'our' declaration
551 /* XXX DAPM integrate this into pad_add_name ??? */
554 Perl_pad_check_dup(pTHX_ const char *name, const STRLEN len, const U32 flags,
560 const U32 is_our = flags & pad_add_OUR;
562 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
564 ASSERT_CURPAD_ACTIVE("pad_check_dup");
566 if (flags & ~pad_add_OUR)
567 Perl_croak(aTHX_ "panic: pad_check_dup illegal flag bits 0x%" UVxf,
570 /* Until we're using the length for real, cross check that we're being told
572 PERL_UNUSED_ARG(len);
573 assert(strlen(name) == len);
575 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
576 return; /* nothing to check */
578 svp = AvARRAY(PL_comppad_name);
579 top = AvFILLp(PL_comppad_name);
580 /* check the current scope */
581 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
583 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
584 SV * const sv = svp[off];
586 && sv != &PL_sv_undef
588 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
589 && strEQ(name, SvPVX_const(sv)))
591 if (is_our && (SvPAD_OUR(sv)))
592 break; /* "our" masking "our" */
593 Perl_warner(aTHX_ packWARN(WARN_MISC),
594 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
595 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
597 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
602 /* check the rest of the pad */
605 SV * const sv = svp[off];
607 && sv != &PL_sv_undef
609 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
610 && SvOURSTASH(sv) == ourstash
611 && strEQ(name, SvPVX_const(sv)))
613 Perl_warner(aTHX_ packWARN(WARN_MISC),
614 "\"our\" variable %"SVf" redeclared", sv);
615 if ((I32)off <= PL_comppad_name_floor)
616 Perl_warner(aTHX_ packWARN(WARN_MISC),
617 "\t(Did you mean \"local\" instead of \"our\"?)\n");
620 } while ( off-- > 0 );
626 =for apidoc pad_findmy
628 Given a lexical name, try to find its offset, first in the current pad,
629 or failing that, in the pads of any lexically enclosing subs (including
630 the complications introduced by eval). If the name is found in an outer pad,
631 then a fake entry is added to the current pad.
632 Returns the offset in the current pad, or NOT_IN_PAD on failure.
638 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
647 PERL_ARGS_ASSERT_PAD_FINDMY;
649 pad_peg("pad_findmy");
652 Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
655 /* Yes, it is a bug (read work in progress) that we're not really using this
656 length parameter, and instead relying on strlen() later on. But I'm not
657 comfortable about changing the pad API piecemeal to use and rely on
658 lengths. This only exists to avoid an "unused parameter" warning. */
662 /* But until we're using the length for real, cross check that we're being
664 assert(strlen(name) == len);
666 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
667 NULL, &out_sv, &out_flags);
668 if ((PADOFFSET)offset != NOT_IN_PAD)
671 /* look for an our that's being introduced; this allows
672 * our $foo = 0 unless defined $foo;
673 * to not give a warning. (Yes, this is a hack) */
675 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
676 name_svp = AvARRAY(nameav);
677 for (offset = AvFILLp(nameav); offset > 0; offset--) {
678 const SV * const namesv = name_svp[offset];
679 if (namesv && namesv != &PL_sv_undef
681 && (SvPAD_OUR(namesv))
682 && strEQ(SvPVX_const(namesv), name)
683 && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
691 * Returns the offset of a lexical $_, if there is one, at run time.
692 * Used by the UNDERBAR XS macro.
696 Perl_find_rundefsvoffset(pTHX)
701 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
702 NULL, &out_sv, &out_flags);
706 =for apidoc pad_findlex
708 Find a named lexical anywhere in a chain of nested pads. Add fake entries
709 in the inner pads if it's found in an outer one.
711 Returns the offset in the bottom pad of the lex or the fake lex.
712 cv is the CV in which to start the search, and seq is the current cop_seq
713 to match against. If warn is true, print appropriate warnings. The out_*
714 vars return values, and so are pointers to where the returned values
715 should be stored. out_capture, if non-null, requests that the innermost
716 instance of the lexical is captured; out_name_sv is set to the innermost
717 matched namesv or fake namesv; out_flags returns the flags normally
718 associated with the IVX field of a fake namesv.
720 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
721 then comes back down, adding fake entries as it goes. It has to be this way
722 because fake namesvs in anon protoypes have to store in xlow the index into
728 /* the CV has finished being compiled. This is not a sufficient test for
729 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
730 #define CvCOMPILED(cv) CvROOT(cv)
732 /* the CV does late binding of its lexicals */
733 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
737 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
738 SV** out_capture, SV** out_name_sv, int *out_flags)
741 I32 offset, new_offset;
744 const AV * const padlist = CvPADLIST(cv);
746 PERL_ARGS_ASSERT_PAD_FINDLEX;
750 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
751 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
752 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
754 /* first, search this pad */
756 if (padlist) { /* not an undef CV */
758 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
759 SV * const * const name_svp = AvARRAY(nameav);
761 for (offset = AvFILLp(nameav); offset > 0; offset--) {
762 const SV * const namesv = name_svp[offset];
763 if (namesv && namesv != &PL_sv_undef
764 && strEQ(SvPVX_const(namesv), name))
767 fake_offset = offset; /* in case we don't find a real one */
768 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
769 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
774 if (offset > 0 || fake_offset > 0 ) { /* a match! */
775 if (offset > 0) { /* not fake */
777 *out_name_sv = name_svp[offset]; /* return the namesv */
779 /* set PAD_FAKELEX_MULTI if this lex can have multiple
780 * instances. For now, we just test !CvUNIQUE(cv), but
781 * ideally, we should detect my's declared within loops
782 * etc - this would allow a wider range of 'not stayed
783 * shared' warnings. We also treated alreadly-compiled
784 * lexes as not multi as viewed from evals. */
786 *out_flags = CvANON(cv) ?
788 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
789 ? PAD_FAKELEX_MULTI : 0;
791 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
792 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
793 PTR2UV(cv), (long)offset,
794 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
795 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
797 else { /* fake match */
798 offset = fake_offset;
799 *out_name_sv = name_svp[offset]; /* return the namesv */
800 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
801 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
802 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
803 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
804 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
808 /* return the lex? */
813 if (SvPAD_OUR(*out_name_sv)) {
818 /* trying to capture from an anon prototype? */
820 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
821 : *out_flags & PAD_FAKELEX_ANON)
824 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
825 "Variable \"%s\" is not available", name);
832 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
833 && !SvPAD_STATE(name_svp[offset])
834 && warn && ckWARN(WARN_CLOSURE)) {
836 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
837 "Variable \"%s\" will not stay shared", name);
840 if (fake_offset && CvANON(cv)
841 && CvCLONE(cv) &&!CvCLONED(cv))
844 /* not yet caught - look further up */
845 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
846 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
849 (void) pad_findlex(name, CvOUTSIDE(cv),
851 newwarn, out_capture, out_name_sv, out_flags);
856 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
857 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
858 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
859 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
860 PTR2UV(cv), PTR2UV(*out_capture)));
862 if (SvPADSTALE(*out_capture)
863 && !SvPAD_STATE(name_svp[offset]))
865 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
866 "Variable \"%s\" is not available", name);
872 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
873 else if (*name == '%')
874 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
876 *out_capture = sv_newmortal();
884 /* it's not in this pad - try above */
889 /* out_capture non-null means caller wants us to capture lex; in
890 * addition we capture ourselves unless it's an ANON/format */
891 new_capturep = out_capture ? out_capture :
892 CvLATE(cv) ? NULL : &new_capture;
894 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
895 new_capturep, out_name_sv, out_flags);
896 if ((PADOFFSET)offset == NOT_IN_PAD)
899 /* found in an outer CV. Add appropriate fake entry to this pad */
901 /* don't add new fake entries (via eval) to CVs that we have already
902 * finished compiling, or to undef CVs */
903 if (CvCOMPILED(cv) || !padlist)
904 return 0; /* this dummy (and invalid) value isnt used by the caller */
908 AV * const ocomppad_name = PL_comppad_name;
909 PAD * const ocomppad = PL_comppad;
910 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
911 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
912 PL_curpad = AvARRAY(PL_comppad);
914 new_offset = pad_add_name(
915 SvPVX_const(*out_name_sv),
917 /* state variable ? */
918 pad_add_FAKE | (SvPAD_STATE(*out_name_sv) ? pad_add_STATE : 0),
919 SvPAD_TYPED(*out_name_sv)
920 ? SvSTASH(*out_name_sv) : NULL,
921 SvOURSTASH(*out_name_sv)
924 new_namesv = AvARRAY(PL_comppad_name)[new_offset];
925 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
927 PARENT_PAD_INDEX_set(new_namesv, 0);
928 if (SvPAD_OUR(new_namesv)) {
929 NOOP; /* do nothing */
931 else if (CvLATE(cv)) {
932 /* delayed creation - just note the offset within parent pad */
933 PARENT_PAD_INDEX_set(new_namesv, offset);
937 /* immediate creation - capture outer value right now */
938 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
939 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
940 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
941 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
943 *out_name_sv = new_namesv;
944 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
946 PL_comppad_name = ocomppad_name;
947 PL_comppad = ocomppad;
948 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
958 Get the value at offset po in the current pad.
959 Use macro PAD_SV instead of calling this function directly.
966 Perl_pad_sv(pTHX_ PADOFFSET po)
969 ASSERT_CURPAD_ACTIVE("pad_sv");
972 Perl_croak(aTHX_ "panic: pad_sv po");
973 DEBUG_X(PerlIO_printf(Perl_debug_log,
974 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
975 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
977 return PL_curpad[po];
982 =for apidoc pad_setsv
984 Set the entry at offset po in the current pad to sv.
985 Use the macro PAD_SETSV() rather than calling this function directly.
991 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
995 PERL_ARGS_ASSERT_PAD_SETSV;
997 ASSERT_CURPAD_ACTIVE("pad_setsv");
999 DEBUG_X(PerlIO_printf(Perl_debug_log,
1000 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1001 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1010 =for apidoc pad_block_start
1012 Update the pad compilation state variables on entry to a new block
1017 /* XXX DAPM perhaps:
1018 * - integrate this in general state-saving routine ???
1019 * - combine with the state-saving going on in pad_new ???
1020 * - introduce a new SAVE type that does all this in one go ?
1024 Perl_pad_block_start(pTHX_ int full)
1027 ASSERT_CURPAD_ACTIVE("pad_block_start");
1028 SAVEI32(PL_comppad_name_floor);
1029 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1031 PL_comppad_name_fill = PL_comppad_name_floor;
1032 if (PL_comppad_name_floor < 0)
1033 PL_comppad_name_floor = 0;
1034 SAVEI32(PL_min_intro_pending);
1035 SAVEI32(PL_max_intro_pending);
1036 PL_min_intro_pending = 0;
1037 SAVEI32(PL_comppad_name_fill);
1038 SAVEI32(PL_padix_floor);
1039 PL_padix_floor = PL_padix;
1040 PL_pad_reset_pending = FALSE;
1045 =for apidoc intro_my
1047 "Introduce" my variables to visible status.
1059 ASSERT_CURPAD_ACTIVE("intro_my");
1060 if (! PL_min_intro_pending)
1061 return PL_cop_seqmax;
1063 svp = AvARRAY(PL_comppad_name);
1064 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1065 SV * const sv = svp[i];
1067 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1068 COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
1069 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1070 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1071 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1072 (long)i, SvPVX_const(sv),
1073 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1074 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1078 PL_min_intro_pending = 0;
1079 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1080 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1081 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1083 return PL_cop_seqmax++;
1087 =for apidoc pad_leavemy
1089 Cleanup at end of scope during compilation: set the max seq number for
1090 lexicals in this scope and warn of any lexicals that never got introduced.
1096 Perl_pad_leavemy(pTHX)
1100 SV * const * const svp = AvARRAY(PL_comppad_name);
1102 PL_pad_reset_pending = FALSE;
1104 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1105 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1106 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1107 const SV * const sv = svp[off];
1108 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1109 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1110 "%"SVf" never introduced",
1114 /* "Deintroduce" my variables that are leaving with this scope. */
1115 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1116 const SV * const sv = svp[off];
1117 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1118 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1119 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1120 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1121 (long)off, SvPVX_const(sv),
1122 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1123 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1128 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1129 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1134 =for apidoc pad_swipe
1136 Abandon the tmp in the current pad at offset po and replace with a
1143 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1146 ASSERT_CURPAD_LEGAL("pad_swipe");
1149 if (AvARRAY(PL_comppad) != PL_curpad)
1150 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1152 Perl_croak(aTHX_ "panic: pad_swipe po");
1154 DEBUG_X(PerlIO_printf(Perl_debug_log,
1155 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1156 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1159 SvPADTMP_off(PL_curpad[po]);
1161 SvREFCNT_dec(PL_curpad[po]);
1164 /* if pad tmps aren't shared between ops, then there's no need to
1165 * create a new tmp when an existing op is freed */
1166 #ifdef USE_BROKEN_PAD_RESET
1167 PL_curpad[po] = newSV(0);
1168 SvPADTMP_on(PL_curpad[po]);
1170 PL_curpad[po] = &PL_sv_undef;
1172 if ((I32)po < PL_padix)
1178 =for apidoc pad_reset
1180 Mark all the current temporaries for reuse
1185 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1186 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1187 * on the stack by OPs that use them, there are several ways to get an alias
1188 * to a shared TARG. Such an alias will change randomly and unpredictably.
1189 * We avoid doing this until we can think of a Better Way.
1195 #ifdef USE_BROKEN_PAD_RESET
1196 if (AvARRAY(PL_comppad) != PL_curpad)
1197 Perl_croak(aTHX_ "panic: pad_reset curpad");
1199 DEBUG_X(PerlIO_printf(Perl_debug_log,
1200 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1201 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1202 (long)PL_padix, (long)PL_padix_floor
1206 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1208 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1209 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1210 SvPADTMP_off(PL_curpad[po]);
1212 PL_padix = PL_padix_floor;
1215 PL_pad_reset_pending = FALSE;
1220 =for apidoc pad_tidy
1222 Tidy up a pad after we've finished compiling it:
1223 * remove most stuff from the pads of anonsub prototypes;
1225 * mark tmps as such.
1230 /* XXX DAPM surely most of this stuff should be done properly
1231 * at the right time beforehand, rather than going around afterwards
1232 * cleaning up our mistakes ???
1236 Perl_pad_tidy(pTHX_ padtidy_type type)
1240 ASSERT_CURPAD_ACTIVE("pad_tidy");
1242 /* If this CV has had any 'eval-capable' ops planted in it
1243 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1244 * anon prototypes in the chain of CVs should be marked as cloneable,
1245 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1246 * the right CvOUTSIDE.
1247 * If running with -d, *any* sub may potentially have an eval
1248 * excuted within it.
1251 if (PL_cv_has_eval || PL_perldb) {
1253 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1254 if (cv != PL_compcv && CvCOMPILED(cv))
1255 break; /* no need to mark already-compiled code */
1257 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1258 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1264 /* extend curpad to match namepad */
1265 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1266 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1268 if (type == padtidy_SUBCLONE) {
1269 SV * const * const namep = AvARRAY(PL_comppad_name);
1272 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1275 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1278 * The only things that a clonable function needs in its
1279 * pad are anonymous subs.
1280 * The rest are created anew during cloning.
1282 if (!((namesv = namep[ix]) != NULL &&
1283 namesv != &PL_sv_undef &&
1284 *SvPVX_const(namesv) == '&'))
1286 SvREFCNT_dec(PL_curpad[ix]);
1287 PL_curpad[ix] = NULL;
1291 else if (type == padtidy_SUB) {
1292 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1293 AV * const av = newAV(); /* Will be @_ */
1295 av_store(PL_comppad, 0, MUTABLE_SV(av));
1299 /* XXX DAPM rationalise these two similar branches */
1301 if (type == padtidy_SUB) {
1303 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1304 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1306 if (!SvPADMY(PL_curpad[ix]))
1307 SvPADTMP_on(PL_curpad[ix]);
1310 else if (type == padtidy_FORMAT) {
1312 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1313 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1314 SvPADTMP_on(PL_curpad[ix]);
1317 PL_curpad = AvARRAY(PL_comppad);
1322 =for apidoc pad_free
1324 Free the SV at offset po in the current pad.
1329 /* XXX DAPM integrate with pad_swipe ???? */
1331 Perl_pad_free(pTHX_ PADOFFSET po)
1334 ASSERT_CURPAD_LEGAL("pad_free");
1337 if (AvARRAY(PL_comppad) != PL_curpad)
1338 Perl_croak(aTHX_ "panic: pad_free curpad");
1340 Perl_croak(aTHX_ "panic: pad_free po");
1342 DEBUG_X(PerlIO_printf(Perl_debug_log,
1343 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1344 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1347 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1348 SvPADTMP_off(PL_curpad[po]);
1350 /* SV could be a shared hash key (eg bugid #19022) */
1351 if (!SvIsCOW(PL_curpad[po]))
1352 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1355 if ((I32)po < PL_padix)
1362 =for apidoc do_dump_pad
1364 Dump the contents of a padlist
1370 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1379 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1384 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1385 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1386 pname = AvARRAY(pad_name);
1387 ppad = AvARRAY(pad);
1388 Perl_dump_indent(aTHX_ level, file,
1389 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1390 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1393 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1394 const SV *namesv = pname[ix];
1395 if (namesv && namesv == &PL_sv_undef) {
1400 Perl_dump_indent(aTHX_ level+1, file,
1401 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1404 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1405 SvPVX_const(namesv),
1406 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1407 (unsigned long)PARENT_PAD_INDEX(namesv)
1411 Perl_dump_indent(aTHX_ level+1, file,
1412 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1415 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1416 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1417 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1422 Perl_dump_indent(aTHX_ level+1, file,
1423 "%2d. 0x%"UVxf"<%lu>\n",
1426 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1437 dump the contents of a CV
1444 S_cv_dump(pTHX_ const CV *cv, const char *title)
1447 const CV * const outside = CvOUTSIDE(cv);
1448 AV* const padlist = CvPADLIST(cv);
1450 PERL_ARGS_ASSERT_CV_DUMP;
1452 PerlIO_printf(Perl_debug_log,
1453 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1456 (CvANON(cv) ? "ANON"
1457 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1458 : (cv == PL_main_cv) ? "MAIN"
1459 : CvUNIQUE(cv) ? "UNIQUE"
1460 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1463 : CvANON(outside) ? "ANON"
1464 : (outside == PL_main_cv) ? "MAIN"
1465 : CvUNIQUE(outside) ? "UNIQUE"
1466 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1468 PerlIO_printf(Perl_debug_log,
1469 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1470 do_dump_pad(1, Perl_debug_log, padlist, 1);
1472 #endif /* DEBUGGING */
1479 =for apidoc cv_clone
1481 Clone a CV: make a new CV which points to the same code etc, but which
1482 has a newly-created pad built by copying the prototype pad and capturing
1489 Perl_cv_clone(pTHX_ CV *proto)
1493 AV* const protopadlist = CvPADLIST(proto);
1494 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1495 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1496 SV** const pname = AvARRAY(protopad_name);
1497 SV** const ppad = AvARRAY(protopad);
1498 const I32 fname = AvFILLp(protopad_name);
1499 const I32 fpad = AvFILLp(protopad);
1505 PERL_ARGS_ASSERT_CV_CLONE;
1507 assert(!CvUNIQUE(proto));
1509 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1510 * to a prototype; we instead want the cloned parent who called us.
1511 * Note that in general for formats, CvOUTSIDE != find_runcv */
1513 outside = CvOUTSIDE(proto);
1514 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1515 outside = find_runcv(NULL);
1516 depth = CvDEPTH(outside);
1517 assert(depth || SvTYPE(proto) == SVt_PVFM);
1520 assert(CvPADLIST(outside));
1523 SAVESPTR(PL_compcv);
1525 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1526 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1530 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1531 : savepv(CvFILE(proto));
1533 CvFILE(cv) = CvFILE(proto);
1535 CvGV(cv) = CvGV(proto);
1536 CvSTASH(cv) = CvSTASH(proto);
1538 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1540 CvSTART(cv) = CvSTART(proto);
1541 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1542 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1545 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1547 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1549 av_fill(PL_comppad, fpad);
1550 for (ix = fname; ix >= 0; ix--)
1551 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1553 PL_curpad = AvARRAY(PL_comppad);
1555 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1557 for (ix = fpad; ix > 0; ix--) {
1558 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1560 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1561 if (SvFAKE(namesv)) { /* lexical from outside? */
1562 sv = outpad[PARENT_PAD_INDEX(namesv)];
1564 /* formats may have an inactive parent,
1565 while my $x if $false can leave an active var marked as
1566 stale. And state vars are always available */
1567 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1568 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1569 "Variable \"%s\" is not available", SvPVX_const(namesv));
1573 SvREFCNT_inc_simple_void_NN(sv);
1576 const char sigil = SvPVX_const(namesv)[0];
1578 sv = SvREFCNT_inc(ppad[ix]);
1579 else if (sigil == '@')
1580 sv = MUTABLE_SV(newAV());
1581 else if (sigil == '%')
1582 sv = MUTABLE_SV(newHV());
1586 /* reset the 'assign only once' flag on each state var */
1587 if (SvPAD_STATE(namesv))
1591 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1592 sv = SvREFCNT_inc_NN(ppad[ix]);
1602 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1603 cv_dump(outside, "Outside");
1604 cv_dump(proto, "Proto");
1611 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1612 * The prototype was marked as a candiate for const-ization,
1613 * so try to grab the current const value, and if successful,
1614 * turn into a const sub:
1616 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1619 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1631 =for apidoc pad_fixup_inner_anons
1633 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1634 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1635 moved to a pre-existing CV struct.
1641 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1645 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1646 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1647 SV ** const namepad = AvARRAY(comppad_name);
1648 SV ** const curpad = AvARRAY(comppad);
1650 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1651 PERL_UNUSED_ARG(old_cv);
1653 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1654 const SV * const namesv = namepad[ix];
1655 if (namesv && namesv != &PL_sv_undef
1656 && *SvPVX_const(namesv) == '&')
1658 CV * const innercv = MUTABLE_CV(curpad[ix]);
1659 assert(CvWEAKOUTSIDE(innercv));
1660 assert(CvOUTSIDE(innercv) == old_cv);
1661 CvOUTSIDE(innercv) = new_cv;
1668 =for apidoc pad_push
1670 Push a new pad frame onto the padlist, unless there's already a pad at
1671 this depth, in which case don't bother creating a new one. Then give
1672 the new pad an @_ in slot zero.
1678 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1682 PERL_ARGS_ASSERT_PAD_PUSH;
1684 if (depth > AvFILLp(padlist)) {
1685 SV** const svp = AvARRAY(padlist);
1686 AV* const newpad = newAV();
1687 SV** const oldpad = AvARRAY(svp[depth-1]);
1688 I32 ix = AvFILLp((const AV *)svp[1]);
1689 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1690 SV** const names = AvARRAY(svp[0]);
1693 for ( ;ix > 0; ix--) {
1694 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1695 const char sigil = SvPVX_const(names[ix])[0];
1696 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1697 || (SvFLAGS(names[ix]) & SVpad_STATE)
1700 /* outer lexical or anon code */
1701 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1703 else { /* our own lexical */
1706 sv = MUTABLE_SV(newAV());
1707 else if (sigil == '%')
1708 sv = MUTABLE_SV(newHV());
1711 av_store(newpad, ix, sv);
1715 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1716 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1719 /* save temporaries on recursion? */
1720 SV * const sv = newSV(0);
1721 av_store(newpad, ix, sv);
1727 av_store(newpad, 0, MUTABLE_SV(av));
1730 av_store(padlist, depth, MUTABLE_SV(newpad));
1731 AvFILLp(padlist) = depth;
1737 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1740 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1741 if ( SvPAD_TYPED(*av) ) {
1742 return SvSTASH(*av);
1749 * c-indentation-style: bsd
1751 * indent-tabs-mode: t
1754 * ex: set ts=8 sts=4 sw=4 noet: