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 SVs_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, SVs_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 @_ */
203 av_store(pad, 0, MUTABLE_SV(a0));
207 av_store(pad, 0, NULL);
211 av_store(padlist, 0, MUTABLE_SV(padname));
212 av_store(padlist, 1, MUTABLE_SV(pad));
214 /* ... then update state variables */
216 PL_comppad_name = MUTABLE_AV((*av_fetch(padlist, 0, FALSE)));
217 PL_comppad = MUTABLE_AV((*av_fetch(padlist, 1, FALSE)));
218 PL_curpad = AvARRAY(PL_comppad);
220 if (! (flags & padnew_CLONE)) {
221 PL_comppad_name_fill = 0;
222 PL_min_intro_pending = 0;
227 DEBUG_X(PerlIO_printf(Perl_debug_log,
228 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
229 " name=0x%"UVxf" flags=0x%"UVxf"\n",
230 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
231 PTR2UV(padname), (UV)flags
235 return (PADLIST*)padlist;
239 =for apidoc pad_undef
241 Free the padlist associated with a CV.
242 If parts of it happen to be current, we null the relevant
243 PL_*pad* global vars so that we don't have any dangling references left.
244 We also repoint the CvOUTSIDE of any about-to-be-orphaned
245 inner subs to the outer of this cv.
247 (This function should really be called pad_free, but the name was already
254 Perl_pad_undef(pTHX_ CV* cv)
258 const PADLIST * const padlist = CvPADLIST(cv);
260 PERL_ARGS_ASSERT_PAD_UNDEF;
262 pad_peg("pad_undef");
265 if (SvIS_FREED(padlist)) /* may be during global destruction */
268 DEBUG_X(PerlIO_printf(Perl_debug_log,
269 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
270 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
273 /* detach any '&' anon children in the pad; if afterwards they
274 * are still live, fix up their CvOUTSIDEs to point to our outside,
276 /* XXX DAPM for efficiency, we should only do this if we know we have
277 * children, or integrate this loop with general cleanup */
279 if (!PL_dirty) { /* don't bother during global destruction */
280 CV * const outercv = CvOUTSIDE(cv);
281 const U32 seq = CvOUTSIDE_SEQ(cv);
282 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
283 SV ** const namepad = AvARRAY(comppad_name);
284 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
285 SV ** const curpad = AvARRAY(comppad);
286 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
287 SV * const namesv = namepad[ix];
288 if (namesv && namesv != &PL_sv_undef
289 && *SvPVX_const(namesv) == '&')
291 CV * const innercv = MUTABLE_CV(curpad[ix]);
292 U32 inner_rc = SvREFCNT(innercv);
295 SvREFCNT_dec(namesv);
297 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
299 SvREFCNT_dec(innercv);
303 /* in use, not just a prototype */
304 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
305 assert(CvWEAKOUTSIDE(innercv));
306 /* don't relink to grandfather if he's being freed */
307 if (outercv && SvREFCNT(outercv)) {
308 CvWEAKOUTSIDE_off(innercv);
309 CvOUTSIDE(innercv) = outercv;
310 CvOUTSIDE_SEQ(innercv) = seq;
311 SvREFCNT_inc_simple_void_NN(outercv);
314 CvOUTSIDE(innercv) = NULL;
321 ix = AvFILLp(padlist);
323 SV* const sv = AvARRAY(padlist)[ix--];
325 if (sv == (const SV *)PL_comppad_name)
326 PL_comppad_name = NULL;
327 else if (sv == (const SV *)PL_comppad) {
334 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
335 CvPADLIST(cv) = NULL;
342 S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
346 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
348 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
350 ASSERT_CURPAD_ACTIVE("pad_add_name");
353 assert(SvTYPE(namesv) == SVt_PVMG);
354 SvPAD_TYPED_on(namesv);
355 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
358 SvPAD_OUR_on(namesv);
359 SvOURSTASH_set(namesv, ourstash);
360 SvREFCNT_inc_simple_void_NN(ourstash);
362 else if (flags & padadd_STATE) {
363 SvPAD_STATE_on(namesv);
366 av_store(PL_comppad_name, offset, namesv);
371 =for apidoc pad_add_name
373 Create a new name and associated PADMY SV in the current pad; return the
375 If C<typestash> is valid, the name is for a typed lexical; set the
376 name's stash to that value.
377 If C<ourstash> is valid, it's an our lexical, set the name's
378 SvOURSTASH to that value
380 If fake, it means we're cloning an existing entry
386 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
387 HV *typestash, HV *ourstash)
393 PERL_ARGS_ASSERT_PAD_ADD_NAME;
395 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
396 Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
399 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
401 /* Until we're using the length for real, cross check that we're being told
403 PERL_UNUSED_ARG(len);
404 assert(strlen(name) == len);
406 sv_setpv(namesv, name);
408 if ((flags & padadd_NO_DUP_CHECK) == 0) {
409 /* check for duplicate declaration */
410 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
413 offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
415 /* not yet introduced */
416 COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
417 COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
419 if (!PL_min_intro_pending)
420 PL_min_intro_pending = offset;
421 PL_max_intro_pending = offset;
422 /* if it's not a simple scalar, replace with an AV or HV */
423 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
424 assert(SvREFCNT(PL_curpad[offset]) == 1);
426 sv_upgrade(PL_curpad[offset], SVt_PVAV);
427 else if (*name == '%')
428 sv_upgrade(PL_curpad[offset], SVt_PVHV);
429 assert(SvPADMY(PL_curpad[offset]));
430 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
431 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
432 (long)offset, name, PTR2UV(PL_curpad[offset])));
441 =for apidoc pad_alloc
443 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
444 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
445 for a slot which has no name and no active value.
450 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
451 * or at least rationalise ??? */
452 /* And flag whether the incoming name is UTF8 or 8 bit?
453 Could do this either with the +ve/-ve hack of the HV code, or expanding
454 the flag bits. Either way, this makes proper Unicode safe pad support.
459 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
465 PERL_UNUSED_ARG(optype);
466 ASSERT_CURPAD_ACTIVE("pad_alloc");
468 if (AvARRAY(PL_comppad) != PL_curpad)
469 Perl_croak(aTHX_ "panic: pad_alloc");
470 if (PL_pad_reset_pending)
472 if (tmptype & SVs_PADMY) {
473 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
474 retval = AvFILLp(PL_comppad);
477 SV * const * const names = AvARRAY(PL_comppad_name);
478 const SSize_t names_fill = AvFILLp(PL_comppad_name);
481 * "foreach" index vars temporarily become aliases to non-"my"
482 * values. Thus we must skip, not just pad values that are
483 * marked as current pad values, but also those with names.
485 /* HVDS why copy to sv here? we don't seem to use it */
486 if (++PL_padix <= names_fill &&
487 (sv = names[PL_padix]) && sv != &PL_sv_undef)
489 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
490 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
491 !IS_PADGV(sv) && !IS_PADCONST(sv))
496 SvFLAGS(sv) |= tmptype;
497 PL_curpad = AvARRAY(PL_comppad);
499 DEBUG_X(PerlIO_printf(Perl_debug_log,
500 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
501 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
502 PL_op_name[optype]));
503 #ifdef DEBUG_LEAKING_SCALARS
504 sv->sv_debug_optype = optype;
505 sv->sv_debug_inpad = 1;
507 return (PADOFFSET)retval;
511 =for apidoc pad_add_anon
513 Add an anon code entry to the current compiling pad
519 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
523 SV* const name = newSV_type(SVt_PVNV);
525 PERL_ARGS_ASSERT_PAD_ADD_ANON;
528 sv_setpvs(name, "&");
529 /* Are these two actually ever read? */
530 COP_SEQ_RANGE_HIGH_set(name, ~0);
531 COP_SEQ_RANGE_LOW_set(name, 1);
532 ix = pad_alloc(op_type, SVs_PADMY);
533 av_store(PL_comppad_name, ix, name);
534 /* XXX DAPM use PL_curpad[] ? */
535 av_store(PL_comppad, ix, sv);
538 /* to avoid ref loops, we never have parent + child referencing each
539 * other simultaneously */
540 if (CvOUTSIDE((const CV *)sv)) {
541 assert(!CvWEAKOUTSIDE((const CV *)sv));
542 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
543 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
551 =for apidoc pad_check_dup
553 Check for duplicate declarations: report any of:
554 * a my in the current scope with the same name;
555 * an our (anywhere in the pad) with the same name and the same stash
557 C<is_our> indicates that the name to check is an 'our' declaration
563 S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
568 const U32 is_our = flags & padadd_OUR;
570 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
572 ASSERT_CURPAD_ACTIVE("pad_check_dup");
574 assert((flags & ~padadd_OUR) == 0);
576 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
577 return; /* nothing to check */
579 svp = AvARRAY(PL_comppad_name);
580 top = AvFILLp(PL_comppad_name);
581 /* check the current scope */
582 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
584 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
585 SV * const sv = svp[off];
587 && sv != &PL_sv_undef
589 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
592 if (is_our && (SvPAD_OUR(sv)))
593 break; /* "our" masking "our" */
594 Perl_warner(aTHX_ packWARN(WARN_MISC),
595 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
596 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
598 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
603 /* check the rest of the pad */
606 SV * const sv = svp[off];
608 && sv != &PL_sv_undef
610 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
611 && SvOURSTASH(sv) == ourstash
614 Perl_warner(aTHX_ packWARN(WARN_MISC),
615 "\"our\" variable %"SVf" redeclared", sv);
616 if ((I32)off <= PL_comppad_name_floor)
617 Perl_warner(aTHX_ packWARN(WARN_MISC),
618 "\t(Did you mean \"local\" instead of \"our\"?)\n");
621 } while ( off-- > 0 );
627 =for apidoc pad_findmy
629 Given a lexical name, try to find its offset, first in the current pad,
630 or failing that, in the pads of any lexically enclosing subs (including
631 the complications introduced by eval). If the name is found in an outer pad,
632 then a fake entry is added to the current pad.
633 Returns the offset in the current pad, or NOT_IN_PAD on failure.
639 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
648 PERL_ARGS_ASSERT_PAD_FINDMY;
650 pad_peg("pad_findmy");
653 Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
656 /* Yes, it is a bug (read work in progress) that we're not really using this
657 length parameter, and instead relying on strlen() later on. But I'm not
658 comfortable about changing the pad API piecemeal to use and rely on
659 lengths. This only exists to avoid an "unused parameter" warning. */
663 /* But until we're using the length for real, cross check that we're being
665 assert(strlen(name) == len);
667 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
668 NULL, &out_sv, &out_flags);
669 if ((PADOFFSET)offset != NOT_IN_PAD)
672 /* look for an our that's being introduced; this allows
673 * our $foo = 0 unless defined $foo;
674 * to not give a warning. (Yes, this is a hack) */
676 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
677 name_svp = AvARRAY(nameav);
678 for (offset = AvFILLp(nameav); offset > 0; offset--) {
679 const SV * const namesv = name_svp[offset];
680 if (namesv && namesv != &PL_sv_undef
682 && (SvPAD_OUR(namesv))
683 && strEQ(SvPVX_const(namesv), name)
684 && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
692 * Returns the offset of a lexical $_, if there is one, at run time.
693 * Used by the UNDERBAR XS macro.
697 Perl_find_rundefsvoffset(pTHX)
702 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
703 NULL, &out_sv, &out_flags);
707 * Returns a lexical $_, if there is one, at run time ; or the global one
712 Perl_find_rundefsv(pTHX)
718 po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
719 NULL, &namesv, &flags);
722 || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
729 =for apidoc pad_findlex
731 Find a named lexical anywhere in a chain of nested pads. Add fake entries
732 in the inner pads if it's found in an outer one.
734 Returns the offset in the bottom pad of the lex or the fake lex.
735 cv is the CV in which to start the search, and seq is the current cop_seq
736 to match against. If warn is true, print appropriate warnings. The out_*
737 vars return values, and so are pointers to where the returned values
738 should be stored. out_capture, if non-null, requests that the innermost
739 instance of the lexical is captured; out_name_sv is set to the innermost
740 matched namesv or fake namesv; out_flags returns the flags normally
741 associated with the IVX field of a fake namesv.
743 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
744 then comes back down, adding fake entries as it goes. It has to be this way
745 because fake namesvs in anon protoypes have to store in xlow the index into
751 /* the CV has finished being compiled. This is not a sufficient test for
752 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
753 #define CvCOMPILED(cv) CvROOT(cv)
755 /* the CV does late binding of its lexicals */
756 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
760 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
761 SV** out_capture, SV** out_name_sv, int *out_flags)
764 I32 offset, new_offset;
767 const AV * const padlist = CvPADLIST(cv);
769 PERL_ARGS_ASSERT_PAD_FINDLEX;
773 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
774 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
775 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
777 /* first, search this pad */
779 if (padlist) { /* not an undef CV */
781 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
782 SV * const * const name_svp = AvARRAY(nameav);
784 for (offset = AvFILLp(nameav); offset > 0; offset--) {
785 const SV * const namesv = name_svp[offset];
786 if (namesv && namesv != &PL_sv_undef
787 && strEQ(SvPVX_const(namesv), name))
790 fake_offset = offset; /* in case we don't find a real one */
791 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
792 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
797 if (offset > 0 || fake_offset > 0 ) { /* a match! */
798 if (offset > 0) { /* not fake */
800 *out_name_sv = name_svp[offset]; /* return the namesv */
802 /* set PAD_FAKELEX_MULTI if this lex can have multiple
803 * instances. For now, we just test !CvUNIQUE(cv), but
804 * ideally, we should detect my's declared within loops
805 * etc - this would allow a wider range of 'not stayed
806 * shared' warnings. We also treated alreadly-compiled
807 * lexes as not multi as viewed from evals. */
809 *out_flags = CvANON(cv) ?
811 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
812 ? PAD_FAKELEX_MULTI : 0;
814 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
815 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
816 PTR2UV(cv), (long)offset,
817 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
818 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
820 else { /* fake match */
821 offset = fake_offset;
822 *out_name_sv = name_svp[offset]; /* return the namesv */
823 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
824 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
825 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
826 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
827 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
831 /* return the lex? */
836 if (SvPAD_OUR(*out_name_sv)) {
841 /* trying to capture from an anon prototype? */
843 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
844 : *out_flags & PAD_FAKELEX_ANON)
847 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
848 "Variable \"%s\" is not available", name);
855 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
856 && !SvPAD_STATE(name_svp[offset])
857 && warn && ckWARN(WARN_CLOSURE)) {
859 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
860 "Variable \"%s\" will not stay shared", name);
863 if (fake_offset && CvANON(cv)
864 && CvCLONE(cv) &&!CvCLONED(cv))
867 /* not yet caught - look further up */
868 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
869 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
872 (void) pad_findlex(name, CvOUTSIDE(cv),
874 newwarn, out_capture, out_name_sv, out_flags);
879 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
880 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
881 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
882 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
883 PTR2UV(cv), PTR2UV(*out_capture)));
885 if (SvPADSTALE(*out_capture)
886 && !SvPAD_STATE(name_svp[offset]))
888 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
889 "Variable \"%s\" is not available", name);
895 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
896 else if (*name == '%')
897 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
899 *out_capture = sv_newmortal();
907 /* it's not in this pad - try above */
912 /* out_capture non-null means caller wants us to capture lex; in
913 * addition we capture ourselves unless it's an ANON/format */
914 new_capturep = out_capture ? out_capture :
915 CvLATE(cv) ? NULL : &new_capture;
917 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
918 new_capturep, out_name_sv, out_flags);
919 if ((PADOFFSET)offset == NOT_IN_PAD)
922 /* found in an outer CV. Add appropriate fake entry to this pad */
924 /* don't add new fake entries (via eval) to CVs that we have already
925 * finished compiling, or to undef CVs */
926 if (CvCOMPILED(cv) || !padlist)
927 return 0; /* this dummy (and invalid) value isnt used by the caller */
930 /* This relies on sv_setsv_flags() upgrading the destination to the same
931 type as the source, independant of the flags set, and on it being
932 "good" and only copying flag bits and pointers that it understands.
934 SV *new_namesv = newSVsv(*out_name_sv);
935 AV * const ocomppad_name = PL_comppad_name;
936 PAD * const ocomppad = PL_comppad;
937 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
938 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
939 PL_curpad = AvARRAY(PL_comppad);
942 = pad_add_name_sv(new_namesv,
943 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
944 SvPAD_TYPED(*out_name_sv)
945 ? SvSTASH(*out_name_sv) : NULL,
946 SvOURSTASH(*out_name_sv)
949 SvFAKE_on(new_namesv);
950 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
951 "Pad addname: %ld \"%.*s\" FAKE\n",
953 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
954 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
956 PARENT_PAD_INDEX_set(new_namesv, 0);
957 if (SvPAD_OUR(new_namesv)) {
958 NOOP; /* do nothing */
960 else if (CvLATE(cv)) {
961 /* delayed creation - just note the offset within parent pad */
962 PARENT_PAD_INDEX_set(new_namesv, offset);
966 /* immediate creation - capture outer value right now */
967 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
968 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
969 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
970 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
972 *out_name_sv = new_namesv;
973 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
975 PL_comppad_name = ocomppad_name;
976 PL_comppad = ocomppad;
977 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
987 Get the value at offset po in the current pad.
988 Use macro PAD_SV instead of calling this function directly.
995 Perl_pad_sv(pTHX_ PADOFFSET po)
998 ASSERT_CURPAD_ACTIVE("pad_sv");
1001 Perl_croak(aTHX_ "panic: pad_sv po");
1002 DEBUG_X(PerlIO_printf(Perl_debug_log,
1003 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1004 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1006 return PL_curpad[po];
1011 =for apidoc pad_setsv
1013 Set the entry at offset po in the current pad to sv.
1014 Use the macro PAD_SETSV() rather than calling this function directly.
1020 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1024 PERL_ARGS_ASSERT_PAD_SETSV;
1026 ASSERT_CURPAD_ACTIVE("pad_setsv");
1028 DEBUG_X(PerlIO_printf(Perl_debug_log,
1029 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1030 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1039 =for apidoc pad_block_start
1041 Update the pad compilation state variables on entry to a new block
1046 /* XXX DAPM perhaps:
1047 * - integrate this in general state-saving routine ???
1048 * - combine with the state-saving going on in pad_new ???
1049 * - introduce a new SAVE type that does all this in one go ?
1053 Perl_pad_block_start(pTHX_ int full)
1056 ASSERT_CURPAD_ACTIVE("pad_block_start");
1057 SAVEI32(PL_comppad_name_floor);
1058 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1060 PL_comppad_name_fill = PL_comppad_name_floor;
1061 if (PL_comppad_name_floor < 0)
1062 PL_comppad_name_floor = 0;
1063 SAVEI32(PL_min_intro_pending);
1064 SAVEI32(PL_max_intro_pending);
1065 PL_min_intro_pending = 0;
1066 SAVEI32(PL_comppad_name_fill);
1067 SAVEI32(PL_padix_floor);
1068 PL_padix_floor = PL_padix;
1069 PL_pad_reset_pending = FALSE;
1074 =for apidoc intro_my
1076 "Introduce" my variables to visible status.
1088 ASSERT_CURPAD_ACTIVE("intro_my");
1089 if (! PL_min_intro_pending)
1090 return PL_cop_seqmax;
1092 svp = AvARRAY(PL_comppad_name);
1093 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1094 SV * const sv = svp[i];
1096 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1097 COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
1098 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1099 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1100 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1101 (long)i, SvPVX_const(sv),
1102 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1103 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1107 PL_min_intro_pending = 0;
1108 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1109 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1110 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1112 return PL_cop_seqmax++;
1116 =for apidoc pad_leavemy
1118 Cleanup at end of scope during compilation: set the max seq number for
1119 lexicals in this scope and warn of any lexicals that never got introduced.
1125 Perl_pad_leavemy(pTHX)
1129 SV * const * const svp = AvARRAY(PL_comppad_name);
1131 PL_pad_reset_pending = FALSE;
1133 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1134 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1135 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1136 const SV * const sv = svp[off];
1137 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1138 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1139 "%"SVf" never introduced",
1143 /* "Deintroduce" my variables that are leaving with this scope. */
1144 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1145 const SV * const sv = svp[off];
1146 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1147 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1148 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1149 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1150 (long)off, SvPVX_const(sv),
1151 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1152 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1157 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1158 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1163 =for apidoc pad_swipe
1165 Abandon the tmp in the current pad at offset po and replace with a
1172 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1175 ASSERT_CURPAD_LEGAL("pad_swipe");
1178 if (AvARRAY(PL_comppad) != PL_curpad)
1179 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1181 Perl_croak(aTHX_ "panic: pad_swipe po");
1183 DEBUG_X(PerlIO_printf(Perl_debug_log,
1184 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1185 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1188 SvPADTMP_off(PL_curpad[po]);
1190 SvREFCNT_dec(PL_curpad[po]);
1193 /* if pad tmps aren't shared between ops, then there's no need to
1194 * create a new tmp when an existing op is freed */
1195 #ifdef USE_BROKEN_PAD_RESET
1196 PL_curpad[po] = newSV(0);
1197 SvPADTMP_on(PL_curpad[po]);
1199 PL_curpad[po] = &PL_sv_undef;
1201 if ((I32)po < PL_padix)
1207 =for apidoc pad_reset
1209 Mark all the current temporaries for reuse
1214 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1215 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1216 * on the stack by OPs that use them, there are several ways to get an alias
1217 * to a shared TARG. Such an alias will change randomly and unpredictably.
1218 * We avoid doing this until we can think of a Better Way.
1224 #ifdef USE_BROKEN_PAD_RESET
1225 if (AvARRAY(PL_comppad) != PL_curpad)
1226 Perl_croak(aTHX_ "panic: pad_reset curpad");
1228 DEBUG_X(PerlIO_printf(Perl_debug_log,
1229 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1230 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1231 (long)PL_padix, (long)PL_padix_floor
1235 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1237 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1238 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1239 SvPADTMP_off(PL_curpad[po]);
1241 PL_padix = PL_padix_floor;
1244 PL_pad_reset_pending = FALSE;
1249 =for apidoc pad_tidy
1251 Tidy up a pad after we've finished compiling it:
1252 * remove most stuff from the pads of anonsub prototypes;
1254 * mark tmps as such.
1259 /* XXX DAPM surely most of this stuff should be done properly
1260 * at the right time beforehand, rather than going around afterwards
1261 * cleaning up our mistakes ???
1265 Perl_pad_tidy(pTHX_ padtidy_type type)
1269 ASSERT_CURPAD_ACTIVE("pad_tidy");
1271 /* If this CV has had any 'eval-capable' ops planted in it
1272 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1273 * anon prototypes in the chain of CVs should be marked as cloneable,
1274 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1275 * the right CvOUTSIDE.
1276 * If running with -d, *any* sub may potentially have an eval
1277 * excuted within it.
1280 if (PL_cv_has_eval || PL_perldb) {
1282 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1283 if (cv != PL_compcv && CvCOMPILED(cv))
1284 break; /* no need to mark already-compiled code */
1286 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1287 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1293 /* extend curpad to match namepad */
1294 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1295 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1297 if (type == padtidy_SUBCLONE) {
1298 SV * const * const namep = AvARRAY(PL_comppad_name);
1301 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1304 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1307 * The only things that a clonable function needs in its
1308 * pad are anonymous subs.
1309 * The rest are created anew during cloning.
1311 if (!((namesv = namep[ix]) != NULL &&
1312 namesv != &PL_sv_undef &&
1313 *SvPVX_const(namesv) == '&'))
1315 SvREFCNT_dec(PL_curpad[ix]);
1316 PL_curpad[ix] = NULL;
1320 else if (type == padtidy_SUB) {
1321 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1322 AV * const av = newAV(); /* Will be @_ */
1323 av_store(PL_comppad, 0, MUTABLE_SV(av));
1327 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1328 SV * const * const namep = AvARRAY(PL_comppad_name);
1330 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1331 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1333 if (!SvPADMY(PL_curpad[ix])) {
1334 SvPADTMP_on(PL_curpad[ix]);
1335 } else if (!SvFAKE(namep[ix])) {
1336 /* This is a work around for how the current implementation of
1337 ?{ } blocks in regexps interacts with lexicals.
1339 One of our lexicals.
1340 Can't do this on all lexicals, otherwise sub baz() won't
1349 because completion of compiling &bar calling pad_tidy()
1350 would cause (top level) $foo to be marked as stale, and
1351 "no longer available". */
1352 SvPADSTALE_on(PL_curpad[ix]);
1356 PL_curpad = AvARRAY(PL_comppad);
1361 =for apidoc pad_free
1363 Free the SV at offset po in the current pad.
1368 /* XXX DAPM integrate with pad_swipe ???? */
1370 Perl_pad_free(pTHX_ PADOFFSET po)
1373 ASSERT_CURPAD_LEGAL("pad_free");
1376 if (AvARRAY(PL_comppad) != PL_curpad)
1377 Perl_croak(aTHX_ "panic: pad_free curpad");
1379 Perl_croak(aTHX_ "panic: pad_free po");
1381 DEBUG_X(PerlIO_printf(Perl_debug_log,
1382 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1383 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1386 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1387 SvPADTMP_off(PL_curpad[po]);
1389 /* SV could be a shared hash key (eg bugid #19022) */
1390 if (!SvIsCOW(PL_curpad[po]))
1391 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1394 if ((I32)po < PL_padix)
1401 =for apidoc do_dump_pad
1403 Dump the contents of a padlist
1409 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1418 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1423 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1424 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1425 pname = AvARRAY(pad_name);
1426 ppad = AvARRAY(pad);
1427 Perl_dump_indent(aTHX_ level, file,
1428 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1429 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1432 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1433 const SV *namesv = pname[ix];
1434 if (namesv && namesv == &PL_sv_undef) {
1439 Perl_dump_indent(aTHX_ level+1, file,
1440 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1443 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1444 SvPVX_const(namesv),
1445 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1446 (unsigned long)PARENT_PAD_INDEX(namesv)
1450 Perl_dump_indent(aTHX_ level+1, file,
1451 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1454 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1455 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1456 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1461 Perl_dump_indent(aTHX_ level+1, file,
1462 "%2d. 0x%"UVxf"<%lu>\n",
1465 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1476 dump the contents of a CV
1483 S_cv_dump(pTHX_ const CV *cv, const char *title)
1486 const CV * const outside = CvOUTSIDE(cv);
1487 AV* const padlist = CvPADLIST(cv);
1489 PERL_ARGS_ASSERT_CV_DUMP;
1491 PerlIO_printf(Perl_debug_log,
1492 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1495 (CvANON(cv) ? "ANON"
1496 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1497 : (cv == PL_main_cv) ? "MAIN"
1498 : CvUNIQUE(cv) ? "UNIQUE"
1499 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1502 : CvANON(outside) ? "ANON"
1503 : (outside == PL_main_cv) ? "MAIN"
1504 : CvUNIQUE(outside) ? "UNIQUE"
1505 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1507 PerlIO_printf(Perl_debug_log,
1508 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1509 do_dump_pad(1, Perl_debug_log, padlist, 1);
1511 #endif /* DEBUGGING */
1518 =for apidoc cv_clone
1520 Clone a CV: make a new CV which points to the same code etc, but which
1521 has a newly-created pad built by copying the prototype pad and capturing
1528 Perl_cv_clone(pTHX_ CV *proto)
1532 AV* const protopadlist = CvPADLIST(proto);
1533 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1534 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1535 SV** const pname = AvARRAY(protopad_name);
1536 SV** const ppad = AvARRAY(protopad);
1537 const I32 fname = AvFILLp(protopad_name);
1538 const I32 fpad = AvFILLp(protopad);
1544 PERL_ARGS_ASSERT_CV_CLONE;
1546 assert(!CvUNIQUE(proto));
1548 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1549 * to a prototype; we instead want the cloned parent who called us.
1550 * Note that in general for formats, CvOUTSIDE != find_runcv */
1552 outside = CvOUTSIDE(proto);
1553 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1554 outside = find_runcv(NULL);
1555 depth = CvDEPTH(outside);
1556 assert(depth || SvTYPE(proto) == SVt_PVFM);
1559 assert(CvPADLIST(outside));
1562 SAVESPTR(PL_compcv);
1564 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1565 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1569 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1570 : savepv(CvFILE(proto));
1572 CvFILE(cv) = CvFILE(proto);
1574 CvGV(cv) = CvGV(proto);
1575 CvSTASH(cv) = CvSTASH(proto);
1577 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1579 CvSTART(cv) = CvSTART(proto);
1580 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1581 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1584 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1586 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1588 av_fill(PL_comppad, fpad);
1589 for (ix = fname; ix >= 0; ix--)
1590 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1592 PL_curpad = AvARRAY(PL_comppad);
1594 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1596 for (ix = fpad; ix > 0; ix--) {
1597 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1599 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1600 if (SvFAKE(namesv)) { /* lexical from outside? */
1601 sv = outpad[PARENT_PAD_INDEX(namesv)];
1603 /* formats may have an inactive parent,
1604 while my $x if $false can leave an active var marked as
1605 stale. And state vars are always available */
1606 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1607 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1608 "Variable \"%s\" is not available", SvPVX_const(namesv));
1612 SvREFCNT_inc_simple_void_NN(sv);
1615 const char sigil = SvPVX_const(namesv)[0];
1617 sv = SvREFCNT_inc(ppad[ix]);
1618 else if (sigil == '@')
1619 sv = MUTABLE_SV(newAV());
1620 else if (sigil == '%')
1621 sv = MUTABLE_SV(newHV());
1625 /* reset the 'assign only once' flag on each state var */
1626 if (SvPAD_STATE(namesv))
1630 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1631 sv = SvREFCNT_inc_NN(ppad[ix]);
1641 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1642 cv_dump(outside, "Outside");
1643 cv_dump(proto, "Proto");
1650 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1651 * The prototype was marked as a candiate for const-ization,
1652 * so try to grab the current const value, and if successful,
1653 * turn into a const sub:
1655 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1658 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1670 =for apidoc pad_fixup_inner_anons
1672 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1673 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1674 moved to a pre-existing CV struct.
1680 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1684 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1685 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1686 SV ** const namepad = AvARRAY(comppad_name);
1687 SV ** const curpad = AvARRAY(comppad);
1689 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1690 PERL_UNUSED_ARG(old_cv);
1692 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1693 const SV * const namesv = namepad[ix];
1694 if (namesv && namesv != &PL_sv_undef
1695 && *SvPVX_const(namesv) == '&')
1697 CV * const innercv = MUTABLE_CV(curpad[ix]);
1698 assert(CvWEAKOUTSIDE(innercv));
1699 assert(CvOUTSIDE(innercv) == old_cv);
1700 CvOUTSIDE(innercv) = new_cv;
1707 =for apidoc pad_push
1709 Push a new pad frame onto the padlist, unless there's already a pad at
1710 this depth, in which case don't bother creating a new one. Then give
1711 the new pad an @_ in slot zero.
1717 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1721 PERL_ARGS_ASSERT_PAD_PUSH;
1723 if (depth > AvFILLp(padlist)) {
1724 SV** const svp = AvARRAY(padlist);
1725 AV* const newpad = newAV();
1726 SV** const oldpad = AvARRAY(svp[depth-1]);
1727 I32 ix = AvFILLp((const AV *)svp[1]);
1728 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1729 SV** const names = AvARRAY(svp[0]);
1732 for ( ;ix > 0; ix--) {
1733 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1734 const char sigil = SvPVX_const(names[ix])[0];
1735 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1736 || (SvFLAGS(names[ix]) & SVpad_STATE)
1739 /* outer lexical or anon code */
1740 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1742 else { /* our own lexical */
1745 sv = MUTABLE_SV(newAV());
1746 else if (sigil == '%')
1747 sv = MUTABLE_SV(newHV());
1750 av_store(newpad, ix, sv);
1754 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1755 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1758 /* save temporaries on recursion? */
1759 SV * const sv = newSV(0);
1760 av_store(newpad, ix, sv);
1765 av_store(newpad, 0, MUTABLE_SV(av));
1768 av_store(padlist, depth, MUTABLE_SV(newpad));
1769 AvFILLp(padlist) = depth;
1775 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1778 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1779 if ( SvPAD_TYPED(*av) ) {
1780 return SvSTASH(*av);
1785 #if defined(USE_ITHREADS)
1787 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1790 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1793 PERL_ARGS_ASSERT_PADLIST_DUP;
1798 assert(!AvREAL(srcpad));
1800 if (param->flags & CLONEf_COPY_STACKS
1801 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1802 /* XXX padlists are real, but pretend to be not */
1804 dstpad = av_dup_inc(srcpad, param);
1807 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1809 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1810 to build anything other than the first level of pads. */
1812 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1814 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1815 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1816 SV **oldpad = AvARRAY(srcpad1);
1820 /* look for it in the table first.
1821 I *think* that it shouldn't be possible to find it there.
1822 Well, except for how Perl_sv_compile_2op() "works" :-( */
1823 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1829 ptr_table_store(PL_ptr_table, srcpad, dstpad);
1831 av_extend(dstpad, 1);
1832 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1833 names = AvARRAY(AvARRAY(dstpad)[0]);
1837 av_extend(pad1, ix);
1838 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1839 pad1a = AvARRAY(pad1);
1840 AvFILLp(dstpad) = 1;
1845 for ( ;ix > 0; ix--) {
1848 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1849 const char sigil = SvPVX_const(names[ix])[0];
1850 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1851 || (SvFLAGS(names[ix]) & SVpad_STATE)
1854 /* outer lexical or anon code */
1855 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1857 else { /* our own lexical */
1858 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1859 /* This is a work around for how the current
1860 implementation of ?{ } blocks in regexps
1861 interacts with lexicals. */
1862 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1867 sv = MUTABLE_SV(newAV());
1868 else if (sigil == '%')
1869 sv = MUTABLE_SV(newHV());
1877 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1878 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1881 /* save temporaries on recursion? */
1882 SV * const sv = newSV(0);
1885 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1886 FIXTHAT before merging this branch.
1887 (And I know how to) */
1888 if (SvPADMY(oldpad[ix]))
1896 args = newAV(); /* Will be @_ */
1898 pad1a[0] = (SV *)args;
1910 * c-indentation-style: bsd
1912 * indent-tabs-mode: t
1915 * ex: set ts=8 sts=4 sw=4 noet: