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 (accessed through the macros COP_SEQ_RANGE_LOW and
82 _HIGH). During compilation, these fields may hold the special value
83 PERL_PADSEQ_INTRO to indicate various stages:
85 COP_SEQ_RANGE_LOW _HIGH
86 ----------------- -----
87 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
88 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
89 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
91 For typed lexicals name SV is SVt_PVMG and SvSTASH
92 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
93 SvOURSTASH slot pointing at the stash of the associated global (so that
94 duplicate C<our> declarations in the same package can be detected). SvUVX is
95 sometimes hijacked to store the generation number during compilation.
97 If SvFAKE is set on the name SV, then that slot in the frame AV is
98 a REFCNT'ed reference to a lexical from "outside". In this case,
99 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
100 in scope throughout. Instead xhigh stores some flags containing info about
101 the real lexical (is it declared in an anon, and is it capable of being
102 instantiated multiple times?), and for fake ANONs, xlow contains the index
103 within the parent's pad where the lexical's value is stored, to make
106 If the 'name' is '&' the corresponding entry in frame AV
107 is a CV representing a possible closure.
108 (SvFAKE and name of '&' is not a meaningful combination currently but could
109 become so if C<my sub foo {}> is implemented.)
111 Note that formats are treated as anon subs, and are cloned each time
112 write is called (if necessary).
114 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
115 and set on scope exit. This allows the 'Variable $x is not available' warning
116 to be generated in evals, such as
118 { my $x = 1; sub f { eval '$x'} } f();
120 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
127 #define PERL_IN_PAD_C
129 #include "keywords.h"
131 #define COP_SEQ_RANGE_LOW_set(sv,val) \
132 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
133 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
134 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
136 #define PARENT_PAD_INDEX_set(sv,val) \
137 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
138 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
139 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
142 void pad_peg(const char* s) {
143 static int pegcnt; /* XXX not threadsafe */
146 PERL_ARGS_ASSERT_PAD_PEG;
155 Create a new compiling padlist, saving and updating the various global
156 vars at the same time as creating the pad itself. The following flags
157 can be OR'ed together:
159 padnew_CLONE this pad is for a cloned CV
160 padnew_SAVE save old globals
161 padnew_SAVESUB also save extra stuff for start of sub
167 Perl_pad_new(pTHX_ int flags)
170 AV *padlist, *padname, *pad;
173 ASSERT_CURPAD_LEGAL("pad_new");
175 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
176 * vars (based on flags) rather than storing vals + addresses for
177 * each individually. Also see pad_block_start.
178 * XXX DAPM Try to see whether all these conditionals are required
181 /* save existing state, ... */
183 if (flags & padnew_SAVE) {
185 SAVESPTR(PL_comppad_name);
186 if (! (flags & padnew_CLONE)) {
188 SAVEI32(PL_comppad_name_fill);
189 SAVEI32(PL_min_intro_pending);
190 SAVEI32(PL_max_intro_pending);
191 SAVEBOOL(PL_cv_has_eval);
192 if (flags & padnew_SAVESUB) {
193 SAVEBOOL(PL_pad_reset_pending);
197 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
198 * saved - check at some pt that this is okay */
200 /* ... create new pad ... */
206 if (flags & padnew_CLONE) {
207 /* XXX DAPM I dont know why cv_clone needs it
208 * doing differently yet - perhaps this separate branch can be
209 * dispensed with eventually ???
212 AV * const a0 = newAV(); /* will be @_ */
213 av_store(pad, 0, MUTABLE_SV(a0));
217 av_store(pad, 0, NULL);
221 /* Most subroutines never recurse, hence only need 2 entries in the padlist
222 array - names, and depth=1. The default for av_store() is to allocate
223 0..3, and even an explicit call to av_extend() with <3 will be rounded
224 up, so we inline the allocation of the array here. */
226 AvFILLp(padlist) = 1;
228 AvALLOC(padlist) = ary;
229 AvARRAY(padlist) = ary;
230 ary[0] = MUTABLE_SV(padname);
231 ary[1] = MUTABLE_SV(pad);
233 /* ... then update state variables */
235 PL_comppad_name = padname;
237 PL_curpad = AvARRAY(pad);
239 if (! (flags & padnew_CLONE)) {
240 PL_comppad_name_fill = 0;
241 PL_min_intro_pending = 0;
246 DEBUG_X(PerlIO_printf(Perl_debug_log,
247 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
248 " name=0x%"UVxf" flags=0x%"UVxf"\n",
249 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
250 PTR2UV(padname), (UV)flags
254 return (PADLIST*)padlist;
259 =head1 Embedding Functions
263 Clear out all the active components of a CV. This can happen either
264 by an explicit C<undef &foo>, or by the reference count going to zero.
265 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
266 children can still follow the full lexical scope chain.
272 Perl_cv_undef(pTHX_ CV *cv)
275 const PADLIST *padlist = CvPADLIST(cv);
277 PERL_ARGS_ASSERT_CV_UNDEF;
279 DEBUG_X(PerlIO_printf(Perl_debug_log,
280 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
281 PTR2UV(cv), PTR2UV(PL_comppad))
285 if (CvFILE(cv) && !CvISXSUB(cv)) {
286 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
287 Safefree(CvFILE(cv));
292 if (!CvISXSUB(cv) && CvROOT(cv)) {
293 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
294 Perl_croak(aTHX_ "Can't undef active subroutine");
297 PAD_SAVE_SETNULLPAD();
304 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
307 /* This statement and the subsequence if block was pad_undef(). */
308 pad_peg("pad_undef");
310 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
314 /* Free the padlist associated with a CV.
315 If parts of it happen to be current, we null the relevant PL_*pad*
316 global vars so that we don't have any dangling references left.
317 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
318 subs to the outer of this cv. */
320 DEBUG_X(PerlIO_printf(Perl_debug_log,
321 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
322 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
325 /* detach any '&' anon children in the pad; if afterwards they
326 * are still live, fix up their CvOUTSIDEs to point to our outside,
328 /* XXX DAPM for efficiency, we should only do this if we know we have
329 * children, or integrate this loop with general cleanup */
331 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
332 CV * const outercv = CvOUTSIDE(cv);
333 const U32 seq = CvOUTSIDE_SEQ(cv);
334 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
335 SV ** const namepad = AvARRAY(comppad_name);
336 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
337 SV ** const curpad = AvARRAY(comppad);
338 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
339 SV * const namesv = namepad[ix];
340 if (namesv && namesv != &PL_sv_undef
341 && *SvPVX_const(namesv) == '&')
343 CV * const innercv = MUTABLE_CV(curpad[ix]);
344 U32 inner_rc = SvREFCNT(innercv);
347 SvREFCNT_dec(namesv);
349 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
351 SvREFCNT_dec(innercv);
355 /* in use, not just a prototype */
356 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
357 assert(CvWEAKOUTSIDE(innercv));
358 /* don't relink to grandfather if he's being freed */
359 if (outercv && SvREFCNT(outercv)) {
360 CvWEAKOUTSIDE_off(innercv);
361 CvOUTSIDE(innercv) = outercv;
362 CvOUTSIDE_SEQ(innercv) = seq;
363 SvREFCNT_inc_simple_void_NN(outercv);
366 CvOUTSIDE(innercv) = NULL;
373 ix = AvFILLp(padlist);
375 SV* const sv = AvARRAY(padlist)[ix--];
377 if (sv == (const SV *)PL_comppad) {
385 SV *const sv = AvARRAY(padlist)[0];
386 if (sv == (const SV *)PL_comppad_name)
387 PL_comppad_name = NULL;
390 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
391 CvPADLIST(cv) = NULL;
395 /* remove CvOUTSIDE unless this is an undef rather than a free */
396 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
397 if (!CvWEAKOUTSIDE(cv))
398 SvREFCNT_dec(CvOUTSIDE(cv));
399 CvOUTSIDE(cv) = NULL;
402 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
405 if (CvISXSUB(cv) && CvXSUB(cv)) {
408 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
409 * ref status of CvOUTSIDE and CvGV */
410 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
414 S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
418 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
420 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
422 ASSERT_CURPAD_ACTIVE("pad_add_name");
425 assert(SvTYPE(namesv) == SVt_PVMG);
426 SvPAD_TYPED_on(namesv);
427 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
430 SvPAD_OUR_on(namesv);
431 SvOURSTASH_set(namesv, ourstash);
432 SvREFCNT_inc_simple_void_NN(ourstash);
434 else if (flags & padadd_STATE) {
435 SvPAD_STATE_on(namesv);
438 av_store(PL_comppad_name, offset, namesv);
443 =for apidoc pad_add_name
445 Create a new name and associated PADMY SV in the current pad; return the
447 If C<typestash> is valid, the name is for a typed lexical; set the
448 name's stash to that value.
449 If C<ourstash> is valid, it's an our lexical, set the name's
450 SvOURSTASH to that value
452 If fake, it means we're cloning an existing entry
458 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
459 HV *typestash, HV *ourstash)
465 PERL_ARGS_ASSERT_PAD_ADD_NAME;
467 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
468 Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
471 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
473 /* Until we're using the length for real, cross check that we're being told
475 PERL_UNUSED_ARG(len);
476 assert(strlen(name) == len);
478 sv_setpv(namesv, name);
480 if ((flags & padadd_NO_DUP_CHECK) == 0) {
481 /* check for duplicate declaration */
482 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
485 offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
487 /* not yet introduced */
488 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
489 COP_SEQ_RANGE_HIGH_set(namesv, 0);
491 if (!PL_min_intro_pending)
492 PL_min_intro_pending = offset;
493 PL_max_intro_pending = offset;
494 /* if it's not a simple scalar, replace with an AV or HV */
495 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
496 assert(SvREFCNT(PL_curpad[offset]) == 1);
498 sv_upgrade(PL_curpad[offset], SVt_PVAV);
499 else if (*name == '%')
500 sv_upgrade(PL_curpad[offset], SVt_PVHV);
501 assert(SvPADMY(PL_curpad[offset]));
502 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
503 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
504 (long)offset, name, PTR2UV(PL_curpad[offset])));
513 =for apidoc pad_alloc
515 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
516 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
517 for a slot which has no name and no active value.
522 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
523 * or at least rationalise ??? */
524 /* And flag whether the incoming name is UTF8 or 8 bit?
525 Could do this either with the +ve/-ve hack of the HV code, or expanding
526 the flag bits. Either way, this makes proper Unicode safe pad support.
531 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
537 PERL_UNUSED_ARG(optype);
538 ASSERT_CURPAD_ACTIVE("pad_alloc");
540 if (AvARRAY(PL_comppad) != PL_curpad)
541 Perl_croak(aTHX_ "panic: pad_alloc");
542 if (PL_pad_reset_pending)
544 if (tmptype & SVs_PADMY) {
545 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
546 retval = AvFILLp(PL_comppad);
549 SV * const * const names = AvARRAY(PL_comppad_name);
550 const SSize_t names_fill = AvFILLp(PL_comppad_name);
553 * "foreach" index vars temporarily become aliases to non-"my"
554 * values. Thus we must skip, not just pad values that are
555 * marked as current pad values, but also those with names.
557 /* HVDS why copy to sv here? we don't seem to use it */
558 if (++PL_padix <= names_fill &&
559 (sv = names[PL_padix]) && sv != &PL_sv_undef)
561 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
562 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
563 !IS_PADGV(sv) && !IS_PADCONST(sv))
568 SvFLAGS(sv) |= tmptype;
569 PL_curpad = AvARRAY(PL_comppad);
571 DEBUG_X(PerlIO_printf(Perl_debug_log,
572 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
573 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
574 PL_op_name[optype]));
575 #ifdef DEBUG_LEAKING_SCALARS
576 sv->sv_debug_optype = optype;
577 sv->sv_debug_inpad = 1;
579 return (PADOFFSET)retval;
583 =for apidoc pad_add_anon
585 Add an anon code entry to the current compiling pad
591 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
595 SV* const name = newSV_type(SVt_PVNV);
597 PERL_ARGS_ASSERT_PAD_ADD_ANON;
600 sv_setpvs(name, "&");
601 /* These two aren't used; just make sure they're not equal to
602 * PERL_PADSEQ_INTRO */
603 COP_SEQ_RANGE_LOW_set(name, 0);
604 COP_SEQ_RANGE_HIGH_set(name, 0);
605 ix = pad_alloc(op_type, SVs_PADMY);
606 av_store(PL_comppad_name, ix, name);
607 /* XXX DAPM use PL_curpad[] ? */
608 av_store(PL_comppad, ix, sv);
611 /* to avoid ref loops, we never have parent + child referencing each
612 * other simultaneously */
613 if (CvOUTSIDE((const CV *)sv)) {
614 assert(!CvWEAKOUTSIDE((const CV *)sv));
615 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
616 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
624 =for apidoc pad_check_dup
626 Check for duplicate declarations: report any of:
627 * a my in the current scope with the same name;
628 * an our (anywhere in the pad) with the same name and the same stash
630 C<is_our> indicates that the name to check is an 'our' declaration
636 S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
641 const U32 is_our = flags & padadd_OUR;
643 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
645 ASSERT_CURPAD_ACTIVE("pad_check_dup");
647 assert((flags & ~padadd_OUR) == 0);
649 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
650 return; /* nothing to check */
652 svp = AvARRAY(PL_comppad_name);
653 top = AvFILLp(PL_comppad_name);
654 /* check the current scope */
655 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
657 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
658 SV * const sv = svp[off];
660 && sv != &PL_sv_undef
662 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
663 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
666 if (is_our && (SvPAD_OUR(sv)))
667 break; /* "our" masking "our" */
668 Perl_warner(aTHX_ packWARN(WARN_MISC),
669 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
670 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
672 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
673 ? "scope" : "statement"));
678 /* check the rest of the pad */
681 SV * const sv = svp[off];
683 && sv != &PL_sv_undef
685 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
686 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
687 && SvOURSTASH(sv) == ourstash
690 Perl_warner(aTHX_ packWARN(WARN_MISC),
691 "\"our\" variable %"SVf" redeclared", sv);
692 if ((I32)off <= PL_comppad_name_floor)
693 Perl_warner(aTHX_ packWARN(WARN_MISC),
694 "\t(Did you mean \"local\" instead of \"our\"?)\n");
704 =for apidoc pad_findmy
706 Given a lexical name, try to find its offset, first in the current pad,
707 or failing that, in the pads of any lexically enclosing subs (including
708 the complications introduced by eval). If the name is found in an outer pad,
709 then a fake entry is added to the current pad.
710 Returns the offset in the current pad, or NOT_IN_PAD on failure.
716 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
725 PERL_ARGS_ASSERT_PAD_FINDMY;
727 pad_peg("pad_findmy");
730 Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
733 /* Yes, it is a bug (read work in progress) that we're not really using this
734 length parameter, and instead relying on strlen() later on. But I'm not
735 comfortable about changing the pad API piecemeal to use and rely on
736 lengths. This only exists to avoid an "unused parameter" warning. */
740 /* But until we're using the length for real, cross check that we're being
742 assert(strlen(name) == len);
744 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
745 NULL, &out_sv, &out_flags);
746 if ((PADOFFSET)offset != NOT_IN_PAD)
749 /* look for an our that's being introduced; this allows
750 * our $foo = 0 unless defined $foo;
751 * to not give a warning. (Yes, this is a hack) */
753 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
754 name_svp = AvARRAY(nameav);
755 for (offset = AvFILLp(nameav); offset > 0; offset--) {
756 const SV * const namesv = name_svp[offset];
757 if (namesv && namesv != &PL_sv_undef
759 && (SvPAD_OUR(namesv))
760 && strEQ(SvPVX_const(namesv), name)
761 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
769 * Returns the offset of a lexical $_, if there is one, at run time.
770 * Used by the UNDERBAR XS macro.
774 Perl_find_rundefsvoffset(pTHX)
779 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
780 NULL, &out_sv, &out_flags);
784 * Returns a lexical $_, if there is one, at run time ; or the global one
789 Perl_find_rundefsv(pTHX)
795 po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
796 NULL, &namesv, &flags);
799 || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
806 =for apidoc pad_findlex
808 Find a named lexical anywhere in a chain of nested pads. Add fake entries
809 in the inner pads if it's found in an outer one.
811 Returns the offset in the bottom pad of the lex or the fake lex.
812 cv is the CV in which to start the search, and seq is the current cop_seq
813 to match against. If warn is true, print appropriate warnings. The out_*
814 vars return values, and so are pointers to where the returned values
815 should be stored. out_capture, if non-null, requests that the innermost
816 instance of the lexical is captured; out_name_sv is set to the innermost
817 matched namesv or fake namesv; out_flags returns the flags normally
818 associated with the IVX field of a fake namesv.
820 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
821 then comes back down, adding fake entries as it goes. It has to be this way
822 because fake namesvs in anon protoypes have to store in xlow the index into
828 /* the CV has finished being compiled. This is not a sufficient test for
829 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
830 #define CvCOMPILED(cv) CvROOT(cv)
832 /* the CV does late binding of its lexicals */
833 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
837 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
838 SV** out_capture, SV** out_name_sv, int *out_flags)
841 I32 offset, new_offset;
844 const AV * const padlist = CvPADLIST(cv);
846 PERL_ARGS_ASSERT_PAD_FINDLEX;
850 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
851 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
852 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
854 /* first, search this pad */
856 if (padlist) { /* not an undef CV */
858 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
859 SV * const * const name_svp = AvARRAY(nameav);
861 for (offset = AvFILLp(nameav); offset > 0; offset--) {
862 const SV * const namesv = name_svp[offset];
863 if (namesv && namesv != &PL_sv_undef
864 && strEQ(SvPVX_const(namesv), name))
866 if (SvFAKE(namesv)) {
867 fake_offset = offset; /* in case we don't find a real one */
870 /* is seq within the range _LOW to _HIGH ?
871 * This is complicated by the fact that PL_cop_seqmax
872 * may have wrapped around at some point */
873 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
874 continue; /* not yet introduced */
876 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
877 /* in compiling scope */
879 (seq > COP_SEQ_RANGE_LOW(namesv))
880 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
881 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
886 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
888 ( seq > COP_SEQ_RANGE_LOW(namesv)
889 || seq <= COP_SEQ_RANGE_HIGH(namesv))
891 : ( seq > COP_SEQ_RANGE_LOW(namesv)
892 && seq <= COP_SEQ_RANGE_HIGH(namesv))
898 if (offset > 0 || fake_offset > 0 ) { /* a match! */
899 if (offset > 0) { /* not fake */
901 *out_name_sv = name_svp[offset]; /* return the namesv */
903 /* set PAD_FAKELEX_MULTI if this lex can have multiple
904 * instances. For now, we just test !CvUNIQUE(cv), but
905 * ideally, we should detect my's declared within loops
906 * etc - this would allow a wider range of 'not stayed
907 * shared' warnings. We also treated already-compiled
908 * lexes as not multi as viewed from evals. */
910 *out_flags = CvANON(cv) ?
912 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
913 ? PAD_FAKELEX_MULTI : 0;
915 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
916 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
917 PTR2UV(cv), (long)offset,
918 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
919 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
921 else { /* fake match */
922 offset = fake_offset;
923 *out_name_sv = name_svp[offset]; /* return the namesv */
924 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
925 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
926 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
927 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
928 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
932 /* return the lex? */
937 if (SvPAD_OUR(*out_name_sv)) {
942 /* trying to capture from an anon prototype? */
944 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
945 : *out_flags & PAD_FAKELEX_ANON)
948 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
949 "Variable \"%s\" is not available", name);
956 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
957 && !SvPAD_STATE(name_svp[offset])
958 && warn && ckWARN(WARN_CLOSURE)) {
960 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
961 "Variable \"%s\" will not stay shared", name);
964 if (fake_offset && CvANON(cv)
965 && CvCLONE(cv) &&!CvCLONED(cv))
968 /* not yet caught - look further up */
969 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
970 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
973 (void) pad_findlex(name, CvOUTSIDE(cv),
975 newwarn, out_capture, out_name_sv, out_flags);
980 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
981 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
982 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
983 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
984 PTR2UV(cv), PTR2UV(*out_capture)));
986 if (SvPADSTALE(*out_capture)
987 && !SvPAD_STATE(name_svp[offset]))
989 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
990 "Variable \"%s\" is not available", name);
996 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
997 else if (*name == '%')
998 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1000 *out_capture = sv_newmortal();
1008 /* it's not in this pad - try above */
1013 /* out_capture non-null means caller wants us to capture lex; in
1014 * addition we capture ourselves unless it's an ANON/format */
1015 new_capturep = out_capture ? out_capture :
1016 CvLATE(cv) ? NULL : &new_capture;
1018 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1019 new_capturep, out_name_sv, out_flags);
1020 if ((PADOFFSET)offset == NOT_IN_PAD)
1023 /* found in an outer CV. Add appropriate fake entry to this pad */
1025 /* don't add new fake entries (via eval) to CVs that we have already
1026 * finished compiling, or to undef CVs */
1027 if (CvCOMPILED(cv) || !padlist)
1028 return 0; /* this dummy (and invalid) value isnt used by the caller */
1031 /* This relies on sv_setsv_flags() upgrading the destination to the same
1032 type as the source, independent of the flags set, and on it being
1033 "good" and only copying flag bits and pointers that it understands.
1035 SV *new_namesv = newSVsv(*out_name_sv);
1036 AV * const ocomppad_name = PL_comppad_name;
1037 PAD * const ocomppad = PL_comppad;
1038 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1039 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1040 PL_curpad = AvARRAY(PL_comppad);
1043 = pad_add_name_sv(new_namesv,
1044 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1045 SvPAD_TYPED(*out_name_sv)
1046 ? SvSTASH(*out_name_sv) : NULL,
1047 SvOURSTASH(*out_name_sv)
1050 SvFAKE_on(new_namesv);
1051 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1052 "Pad addname: %ld \"%.*s\" FAKE\n",
1054 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1055 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1057 PARENT_PAD_INDEX_set(new_namesv, 0);
1058 if (SvPAD_OUR(new_namesv)) {
1059 NOOP; /* do nothing */
1061 else if (CvLATE(cv)) {
1062 /* delayed creation - just note the offset within parent pad */
1063 PARENT_PAD_INDEX_set(new_namesv, offset);
1067 /* immediate creation - capture outer value right now */
1068 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1069 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1070 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1071 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1073 *out_name_sv = new_namesv;
1074 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1076 PL_comppad_name = ocomppad_name;
1077 PL_comppad = ocomppad;
1078 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1088 Get the value at offset po in the current pad.
1089 Use macro PAD_SV instead of calling this function directly.
1096 Perl_pad_sv(pTHX_ PADOFFSET po)
1099 ASSERT_CURPAD_ACTIVE("pad_sv");
1102 Perl_croak(aTHX_ "panic: pad_sv po");
1103 DEBUG_X(PerlIO_printf(Perl_debug_log,
1104 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1105 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1107 return PL_curpad[po];
1112 =for apidoc pad_setsv
1114 Set the entry at offset po in the current pad to sv.
1115 Use the macro PAD_SETSV() rather than calling this function directly.
1121 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1125 PERL_ARGS_ASSERT_PAD_SETSV;
1127 ASSERT_CURPAD_ACTIVE("pad_setsv");
1129 DEBUG_X(PerlIO_printf(Perl_debug_log,
1130 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1131 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1140 =for apidoc pad_block_start
1142 Update the pad compilation state variables on entry to a new block
1147 /* XXX DAPM perhaps:
1148 * - integrate this in general state-saving routine ???
1149 * - combine with the state-saving going on in pad_new ???
1150 * - introduce a new SAVE type that does all this in one go ?
1154 Perl_pad_block_start(pTHX_ int full)
1157 ASSERT_CURPAD_ACTIVE("pad_block_start");
1158 SAVEI32(PL_comppad_name_floor);
1159 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1161 PL_comppad_name_fill = PL_comppad_name_floor;
1162 if (PL_comppad_name_floor < 0)
1163 PL_comppad_name_floor = 0;
1164 SAVEI32(PL_min_intro_pending);
1165 SAVEI32(PL_max_intro_pending);
1166 PL_min_intro_pending = 0;
1167 SAVEI32(PL_comppad_name_fill);
1168 SAVEI32(PL_padix_floor);
1169 PL_padix_floor = PL_padix;
1170 PL_pad_reset_pending = FALSE;
1175 =for apidoc intro_my
1177 "Introduce" my variables to visible status.
1190 ASSERT_CURPAD_ACTIVE("intro_my");
1191 if (! PL_min_intro_pending)
1192 return PL_cop_seqmax;
1194 svp = AvARRAY(PL_comppad_name);
1195 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1196 SV * const sv = svp[i];
1198 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1199 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1201 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1202 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1203 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1204 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1205 (long)i, SvPVX_const(sv),
1206 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1207 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1211 seq = PL_cop_seqmax;
1213 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1215 PL_min_intro_pending = 0;
1216 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1217 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1218 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1224 =for apidoc pad_leavemy
1226 Cleanup at end of scope during compilation: set the max seq number for
1227 lexicals in this scope and warn of any lexicals that never got introduced.
1233 Perl_pad_leavemy(pTHX)
1237 SV * const * const svp = AvARRAY(PL_comppad_name);
1239 PL_pad_reset_pending = FALSE;
1241 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1242 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1243 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1244 const SV * const sv = svp[off];
1245 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1246 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1247 "%"SVf" never introduced",
1251 /* "Deintroduce" my variables that are leaving with this scope. */
1252 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1253 const SV * const sv = svp[off];
1254 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1255 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1257 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1258 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1259 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1260 (long)off, SvPVX_const(sv),
1261 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1262 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1267 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1269 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1270 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1275 =for apidoc pad_swipe
1277 Abandon the tmp in the current pad at offset po and replace with a
1284 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1287 ASSERT_CURPAD_LEGAL("pad_swipe");
1290 if (AvARRAY(PL_comppad) != PL_curpad)
1291 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1293 Perl_croak(aTHX_ "panic: pad_swipe po");
1295 DEBUG_X(PerlIO_printf(Perl_debug_log,
1296 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1297 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1300 SvPADTMP_off(PL_curpad[po]);
1302 SvREFCNT_dec(PL_curpad[po]);
1305 /* if pad tmps aren't shared between ops, then there's no need to
1306 * create a new tmp when an existing op is freed */
1307 #ifdef USE_BROKEN_PAD_RESET
1308 PL_curpad[po] = newSV(0);
1309 SvPADTMP_on(PL_curpad[po]);
1311 PL_curpad[po] = &PL_sv_undef;
1313 if ((I32)po < PL_padix)
1319 =for apidoc pad_reset
1321 Mark all the current temporaries for reuse
1326 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1327 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1328 * on the stack by OPs that use them, there are several ways to get an alias
1329 * to a shared TARG. Such an alias will change randomly and unpredictably.
1330 * We avoid doing this until we can think of a Better Way.
1336 #ifdef USE_BROKEN_PAD_RESET
1337 if (AvARRAY(PL_comppad) != PL_curpad)
1338 Perl_croak(aTHX_ "panic: pad_reset curpad");
1340 DEBUG_X(PerlIO_printf(Perl_debug_log,
1341 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1342 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1343 (long)PL_padix, (long)PL_padix_floor
1347 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1349 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1350 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1351 SvPADTMP_off(PL_curpad[po]);
1353 PL_padix = PL_padix_floor;
1356 PL_pad_reset_pending = FALSE;
1361 =for apidoc pad_tidy
1363 Tidy up a pad after we've finished compiling it:
1364 * remove most stuff from the pads of anonsub prototypes;
1366 * mark tmps as such.
1371 /* XXX DAPM surely most of this stuff should be done properly
1372 * at the right time beforehand, rather than going around afterwards
1373 * cleaning up our mistakes ???
1377 Perl_pad_tidy(pTHX_ padtidy_type type)
1381 ASSERT_CURPAD_ACTIVE("pad_tidy");
1383 /* If this CV has had any 'eval-capable' ops planted in it
1384 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1385 * anon prototypes in the chain of CVs should be marked as cloneable,
1386 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1387 * the right CvOUTSIDE.
1388 * If running with -d, *any* sub may potentially have an eval
1389 * executed within it.
1392 if (PL_cv_has_eval || PL_perldb) {
1394 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1395 if (cv != PL_compcv && CvCOMPILED(cv))
1396 break; /* no need to mark already-compiled code */
1398 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1399 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1405 /* extend curpad to match namepad */
1406 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1407 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1409 if (type == padtidy_SUBCLONE) {
1410 SV * const * const namep = AvARRAY(PL_comppad_name);
1413 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1416 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1419 * The only things that a clonable function needs in its
1420 * pad are anonymous subs.
1421 * The rest are created anew during cloning.
1423 if (!((namesv = namep[ix]) != NULL &&
1424 namesv != &PL_sv_undef &&
1425 *SvPVX_const(namesv) == '&'))
1427 SvREFCNT_dec(PL_curpad[ix]);
1428 PL_curpad[ix] = NULL;
1432 else if (type == padtidy_SUB) {
1433 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1434 AV * const av = newAV(); /* Will be @_ */
1435 av_store(PL_comppad, 0, MUTABLE_SV(av));
1439 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1440 SV * const * const namep = AvARRAY(PL_comppad_name);
1442 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1443 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1445 if (!SvPADMY(PL_curpad[ix])) {
1446 SvPADTMP_on(PL_curpad[ix]);
1447 } else if (!SvFAKE(namep[ix])) {
1448 /* This is a work around for how the current implementation of
1449 ?{ } blocks in regexps interacts with lexicals.
1451 One of our lexicals.
1452 Can't do this on all lexicals, otherwise sub baz() won't
1461 because completion of compiling &bar calling pad_tidy()
1462 would cause (top level) $foo to be marked as stale, and
1463 "no longer available". */
1464 SvPADSTALE_on(PL_curpad[ix]);
1468 PL_curpad = AvARRAY(PL_comppad);
1473 =for apidoc pad_free
1475 Free the SV at offset po in the current pad.
1480 /* XXX DAPM integrate with pad_swipe ???? */
1482 Perl_pad_free(pTHX_ PADOFFSET po)
1485 ASSERT_CURPAD_LEGAL("pad_free");
1488 if (AvARRAY(PL_comppad) != PL_curpad)
1489 Perl_croak(aTHX_ "panic: pad_free curpad");
1491 Perl_croak(aTHX_ "panic: pad_free po");
1493 DEBUG_X(PerlIO_printf(Perl_debug_log,
1494 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1495 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1498 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1499 SvPADTMP_off(PL_curpad[po]);
1501 if ((I32)po < PL_padix)
1508 =for apidoc do_dump_pad
1510 Dump the contents of a padlist
1516 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1525 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1530 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1531 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1532 pname = AvARRAY(pad_name);
1533 ppad = AvARRAY(pad);
1534 Perl_dump_indent(aTHX_ level, file,
1535 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1536 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1539 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1540 const SV *namesv = pname[ix];
1541 if (namesv && namesv == &PL_sv_undef) {
1546 Perl_dump_indent(aTHX_ level+1, file,
1547 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1550 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1551 SvPVX_const(namesv),
1552 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1553 (unsigned long)PARENT_PAD_INDEX(namesv)
1557 Perl_dump_indent(aTHX_ level+1, file,
1558 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1561 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1562 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1563 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1568 Perl_dump_indent(aTHX_ level+1, file,
1569 "%2d. 0x%"UVxf"<%lu>\n",
1572 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1583 dump the contents of a CV
1590 S_cv_dump(pTHX_ const CV *cv, const char *title)
1593 const CV * const outside = CvOUTSIDE(cv);
1594 AV* const padlist = CvPADLIST(cv);
1596 PERL_ARGS_ASSERT_CV_DUMP;
1598 PerlIO_printf(Perl_debug_log,
1599 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1602 (CvANON(cv) ? "ANON"
1603 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1604 : (cv == PL_main_cv) ? "MAIN"
1605 : CvUNIQUE(cv) ? "UNIQUE"
1606 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1609 : CvANON(outside) ? "ANON"
1610 : (outside == PL_main_cv) ? "MAIN"
1611 : CvUNIQUE(outside) ? "UNIQUE"
1612 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1614 PerlIO_printf(Perl_debug_log,
1615 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1616 do_dump_pad(1, Perl_debug_log, padlist, 1);
1618 #endif /* DEBUGGING */
1625 =for apidoc cv_clone
1627 Clone a CV: make a new CV which points to the same code etc, but which
1628 has a newly-created pad built by copying the prototype pad and capturing
1635 Perl_cv_clone(pTHX_ CV *proto)
1639 AV* const protopadlist = CvPADLIST(proto);
1640 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1641 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1642 SV** const pname = AvARRAY(protopad_name);
1643 SV** const ppad = AvARRAY(protopad);
1644 const I32 fname = AvFILLp(protopad_name);
1645 const I32 fpad = AvFILLp(protopad);
1651 PERL_ARGS_ASSERT_CV_CLONE;
1653 assert(!CvUNIQUE(proto));
1655 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1656 * to a prototype; we instead want the cloned parent who called us.
1657 * Note that in general for formats, CvOUTSIDE != find_runcv */
1659 outside = CvOUTSIDE(proto);
1660 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1661 outside = find_runcv(NULL);
1662 depth = CvDEPTH(outside);
1663 assert(depth || SvTYPE(proto) == SVt_PVFM);
1666 assert(CvPADLIST(outside));
1669 SAVESPTR(PL_compcv);
1671 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1672 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1676 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1677 : savepv(CvFILE(proto));
1679 CvFILE(cv) = CvFILE(proto);
1681 CvGV_set(cv,CvGV(proto));
1682 CvSTASH_set(cv, CvSTASH(proto));
1684 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1686 CvSTART(cv) = CvSTART(proto);
1687 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1688 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1691 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1693 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1695 av_fill(PL_comppad, fpad);
1696 for (ix = fname; ix > 0; ix--)
1697 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1699 PL_curpad = AvARRAY(PL_comppad);
1701 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1703 for (ix = fpad; ix > 0; ix--) {
1704 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1706 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1707 if (SvFAKE(namesv)) { /* lexical from outside? */
1708 sv = outpad[PARENT_PAD_INDEX(namesv)];
1710 /* formats may have an inactive parent,
1711 while my $x if $false can leave an active var marked as
1712 stale. And state vars are always available */
1713 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1714 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1715 "Variable \"%s\" is not available", SvPVX_const(namesv));
1719 SvREFCNT_inc_simple_void_NN(sv);
1722 const char sigil = SvPVX_const(namesv)[0];
1724 sv = SvREFCNT_inc(ppad[ix]);
1725 else if (sigil == '@')
1726 sv = MUTABLE_SV(newAV());
1727 else if (sigil == '%')
1728 sv = MUTABLE_SV(newHV());
1732 /* reset the 'assign only once' flag on each state var */
1733 if (SvPAD_STATE(namesv))
1737 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1738 sv = SvREFCNT_inc_NN(ppad[ix]);
1748 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1749 cv_dump(outside, "Outside");
1750 cv_dump(proto, "Proto");
1757 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1758 * The prototype was marked as a candiate for const-ization,
1759 * so try to grab the current const value, and if successful,
1760 * turn into a const sub:
1762 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1765 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1777 =for apidoc pad_fixup_inner_anons
1779 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1780 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1781 moved to a pre-existing CV struct.
1787 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1791 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1792 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1793 SV ** const namepad = AvARRAY(comppad_name);
1794 SV ** const curpad = AvARRAY(comppad);
1796 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1797 PERL_UNUSED_ARG(old_cv);
1799 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1800 const SV * const namesv = namepad[ix];
1801 if (namesv && namesv != &PL_sv_undef
1802 && *SvPVX_const(namesv) == '&')
1804 CV * const innercv = MUTABLE_CV(curpad[ix]);
1805 assert(CvWEAKOUTSIDE(innercv));
1806 assert(CvOUTSIDE(innercv) == old_cv);
1807 CvOUTSIDE(innercv) = new_cv;
1814 =for apidoc pad_push
1816 Push a new pad frame onto the padlist, unless there's already a pad at
1817 this depth, in which case don't bother creating a new one. Then give
1818 the new pad an @_ in slot zero.
1824 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1828 PERL_ARGS_ASSERT_PAD_PUSH;
1830 if (depth > AvFILLp(padlist)) {
1831 SV** const svp = AvARRAY(padlist);
1832 AV* const newpad = newAV();
1833 SV** const oldpad = AvARRAY(svp[depth-1]);
1834 I32 ix = AvFILLp((const AV *)svp[1]);
1835 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1836 SV** const names = AvARRAY(svp[0]);
1839 for ( ;ix > 0; ix--) {
1840 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1841 const char sigil = SvPVX_const(names[ix])[0];
1842 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1843 || (SvFLAGS(names[ix]) & SVpad_STATE)
1846 /* outer lexical or anon code */
1847 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1849 else { /* our own lexical */
1852 sv = MUTABLE_SV(newAV());
1853 else if (sigil == '%')
1854 sv = MUTABLE_SV(newHV());
1857 av_store(newpad, ix, sv);
1861 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1862 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1865 /* save temporaries on recursion? */
1866 SV * const sv = newSV(0);
1867 av_store(newpad, ix, sv);
1872 av_store(newpad, 0, MUTABLE_SV(av));
1875 av_store(padlist, depth, MUTABLE_SV(newpad));
1876 AvFILLp(padlist) = depth;
1882 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1885 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1886 if ( SvPAD_TYPED(*av) ) {
1887 return SvSTASH(*av);
1892 #if defined(USE_ITHREADS)
1894 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1897 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1900 PERL_ARGS_ASSERT_PADLIST_DUP;
1905 assert(!AvREAL(srcpad));
1907 if (param->flags & CLONEf_COPY_STACKS
1908 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1909 /* XXX padlists are real, but pretend to be not */
1911 dstpad = av_dup_inc(srcpad, param);
1914 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1916 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1917 to build anything other than the first level of pads. */
1919 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1921 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1922 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1923 SV **oldpad = AvARRAY(srcpad1);
1927 /* look for it in the table first.
1928 I *think* that it shouldn't be possible to find it there.
1929 Well, except for how Perl_sv_compile_2op() "works" :-( */
1930 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1936 ptr_table_store(PL_ptr_table, srcpad, dstpad);
1938 av_extend(dstpad, 1);
1939 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1940 names = AvARRAY(AvARRAY(dstpad)[0]);
1944 av_extend(pad1, ix);
1945 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1946 pad1a = AvARRAY(pad1);
1947 AvFILLp(dstpad) = 1;
1952 for ( ;ix > 0; ix--) {
1955 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1956 const char sigil = SvPVX_const(names[ix])[0];
1957 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1958 || (SvFLAGS(names[ix]) & SVpad_STATE)
1961 /* outer lexical or anon code */
1962 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1964 else { /* our own lexical */
1965 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1966 /* This is a work around for how the current
1967 implementation of ?{ } blocks in regexps
1968 interacts with lexicals. */
1969 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1974 sv = MUTABLE_SV(newAV());
1975 else if (sigil == '%')
1976 sv = MUTABLE_SV(newHV());
1984 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1985 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1988 /* save temporaries on recursion? */
1989 SV * const sv = newSV(0);
1992 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1993 FIXTHAT before merging this branch.
1994 (And I know how to) */
1995 if (SvPADMY(oldpad[ix]))
2003 args = newAV(); /* Will be @_ */
2005 pad1a[0] = (SV *)args;
2017 * c-indentation-style: bsd
2019 * indent-tabs-mode: t
2022 * ex: set ts=8 sts=4 sw=4 noet: