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 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
32 CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing). Require'd files are simply evals without any outer lexical
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
45 The CvPADLIST AV has the REFCNT of its component items managed "manually"
46 (mostly in pad.c) rather than by normal av.c rules. So we turn off AvREAL
47 just before freeing it, to let av.c know not to touch the entries.
48 The items in the AV are not SVs as for a normal AV, but other AVs:
50 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
51 the "static type information" for lexicals.
53 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
54 depth of recursion into the CV.
55 The 0'th slot of a frame AV is an AV which is @_.
56 other entries are storage for variables and op targets.
58 Iterating over the names AV iterates over all possible pad
59 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
62 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time. These don't have names by which they
65 can be looked up from Perl code at run time through eval"" like
66 my/our variables can be. Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH). During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
76 COP_SEQ_RANGE_LOW _HIGH
77 ----------------- -----
78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
80 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected). SvUVX is
86 sometimes hijacked to store the generation number during compilation.
88 If SvFAKE is set on the name SV, then that slot in the frame AV is
89 a REFCNT'ed reference to a lexical from "outside". In this case,
90 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
91 in scope throughout. Instead xhigh stores some flags containing info about
92 the real lexical (is it declared in an anon, and is it capable of being
93 instantiated multiple times?), and for fake ANONs, xlow contains the index
94 within the parent's pad where the lexical's value is stored, to make
97 If the 'name' is '&' the corresponding entry in frame AV
98 is a CV representing a possible closure.
99 (SvFAKE and name of '&' is not a meaningful combination currently but could
100 become so if C<my sub foo {}> is implemented.)
102 Note that formats are treated as anon subs, and are cloned each time
103 write is called (if necessary).
105 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
106 and set on scope exit. This allows the 'Variable $x is not available' warning
107 to be generated in evals, such as
109 { my $x = 1; sub f { eval '$x'} } f();
111 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
113 =for apidoc AmxU|AV *|PL_comppad_name
115 During compilation, this points to the array containing the names part
116 of the pad for the currently-compiling code.
118 =for apidoc AmxU|AV *|PL_comppad
120 During compilation, this points to the array containing the values
121 part of the pad for the currently-compiling code. (At runtime a CV may
122 have many such value arrays; at compile time just one is constructed.)
123 At runtime, this points to the array containing the currently-relevant
124 values for the pad for the currently-executing code.
126 =for apidoc AmxU|SV **|PL_curpad
128 Points directly to the body of the L</PL_comppad> array.
129 (I.e., this is C<AvARRAY(PL_comppad)>.)
136 #define PERL_IN_PAD_C
138 #include "keywords.h"
140 #define COP_SEQ_RANGE_LOW_set(sv,val) \
141 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
142 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
143 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
145 #define PARENT_PAD_INDEX_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
151 =for apidoc mx|void|pad_peg|const char *s
153 When PERL_MAD is enabled, this is a small no-op function that gets called
154 at the start of each pad-related function. It can be breakpointed to
155 track all pad operations. The parameter is a string indicating the type
156 of pad operation being performed.
162 void pad_peg(const char* s) {
163 static int pegcnt; /* XXX not threadsafe */
166 PERL_ARGS_ASSERT_PAD_PEG;
173 This is basically sv_eq_flags() in sv.c, but we avoid the magic
178 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
179 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
180 const char *pv1 = SvPVX_const(sv);
181 STRLEN cur1 = SvCUR(sv);
182 const char *pv2 = pv;
187 svrecode = newSVpvn(pv2, cur2);
188 sv_recode_to_utf8(svrecode, PL_encoding);
189 pv2 = SvPV_const(svrecode, cur2);
192 svrecode = newSVpvn(pv1, cur1);
193 sv_recode_to_utf8(svrecode, PL_encoding);
194 pv1 = SvPV_const(svrecode, cur1);
196 SvREFCNT_dec(svrecode);
198 if (flags & SVf_UTF8)
199 return (bytes_cmp_utf8(
200 (const U8*)pv1, cur1,
201 (const U8*)pv2, cur2) == 0);
203 return (bytes_cmp_utf8(
204 (const U8*)pv2, cur2,
205 (const U8*)pv1, cur1) == 0);
208 return ((SvPVX_const(sv) == pv)
209 || memEQ(SvPVX_const(sv), pv, pvlen));
214 =for apidoc Am|PADLIST *|pad_new|int flags
216 Create a new padlist, updating the global variables for the
217 currently-compiling padlist to point to the new padlist. The following
218 flags can be OR'ed together:
220 padnew_CLONE this pad is for a cloned CV
221 padnew_SAVE save old globals on the save stack
222 padnew_SAVESUB also save extra stuff for start of sub
228 Perl_pad_new(pTHX_ int flags)
231 AV *padlist, *padname, *pad;
234 ASSERT_CURPAD_LEGAL("pad_new");
236 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
237 * vars (based on flags) rather than storing vals + addresses for
238 * each individually. Also see pad_block_start.
239 * XXX DAPM Try to see whether all these conditionals are required
242 /* save existing state, ... */
244 if (flags & padnew_SAVE) {
246 SAVESPTR(PL_comppad_name);
247 if (! (flags & padnew_CLONE)) {
249 SAVEI32(PL_comppad_name_fill);
250 SAVEI32(PL_min_intro_pending);
251 SAVEI32(PL_max_intro_pending);
252 SAVEBOOL(PL_cv_has_eval);
253 if (flags & padnew_SAVESUB) {
254 SAVEBOOL(PL_pad_reset_pending);
258 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
259 * saved - check at some pt that this is okay */
261 /* ... create new pad ... */
267 if (flags & padnew_CLONE) {
268 /* XXX DAPM I dont know why cv_clone needs it
269 * doing differently yet - perhaps this separate branch can be
270 * dispensed with eventually ???
273 AV * const a0 = newAV(); /* will be @_ */
274 av_store(pad, 0, MUTABLE_SV(a0));
278 av_store(pad, 0, NULL);
281 /* Most subroutines never recurse, hence only need 2 entries in the padlist
282 array - names, and depth=1. The default for av_store() is to allocate
283 0..3, and even an explicit call to av_extend() with <3 will be rounded
284 up, so we inline the allocation of the array here. */
286 AvFILLp(padlist) = 1;
288 AvALLOC(padlist) = ary;
289 AvARRAY(padlist) = ary;
290 ary[0] = MUTABLE_SV(padname);
291 ary[1] = MUTABLE_SV(pad);
293 /* ... then update state variables */
295 PL_comppad_name = padname;
297 PL_curpad = AvARRAY(pad);
299 if (! (flags & padnew_CLONE)) {
300 PL_comppad_name_fill = 0;
301 PL_min_intro_pending = 0;
306 DEBUG_X(PerlIO_printf(Perl_debug_log,
307 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
308 " name=0x%"UVxf" flags=0x%"UVxf"\n",
309 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
310 PTR2UV(padname), (UV)flags
314 return (PADLIST*)padlist;
319 =head1 Embedding Functions
323 Clear out all the active components of a CV. This can happen either
324 by an explicit C<undef &foo>, or by the reference count going to zero.
325 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
326 children can still follow the full lexical scope chain.
332 Perl_cv_undef(pTHX_ CV *cv)
335 const PADLIST *padlist = CvPADLIST(cv);
336 bool const slabbed = !!CvSLABBED(cv);
338 PERL_ARGS_ASSERT_CV_UNDEF;
340 DEBUG_X(PerlIO_printf(Perl_debug_log,
341 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
342 PTR2UV(cv), PTR2UV(PL_comppad))
345 if (CvFILE(cv) && CvDYNFILE(cv)) {
346 Safefree(CvFILE(cv));
351 if (!CvISXSUB(cv) && CvROOT(cv)) {
352 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
353 Perl_croak(aTHX_ "Can't undef active subroutine");
356 PAD_SAVE_SETNULLPAD();
358 #ifndef PL_OP_SLAB_ALLOC
359 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
366 #ifndef PL_OP_SLAB_ALLOC
367 else if (slabbed && CvSTART(cv)) {
369 PAD_SAVE_SETNULLPAD();
371 /* discard any leaked ops */
372 opslab_force_free((OPSLAB *)CvSTART(cv));
378 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
381 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
384 /* This statement and the subsequence if block was pad_undef(). */
385 pad_peg("pad_undef");
387 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
391 /* Free the padlist associated with a CV.
392 If parts of it happen to be current, we null the relevant PL_*pad*
393 global vars so that we don't have any dangling references left.
394 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
395 subs to the outer of this cv. */
397 DEBUG_X(PerlIO_printf(Perl_debug_log,
398 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
399 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
402 /* detach any '&' anon children in the pad; if afterwards they
403 * are still live, fix up their CvOUTSIDEs to point to our outside,
405 /* XXX DAPM for efficiency, we should only do this if we know we have
406 * children, or integrate this loop with general cleanup */
408 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
409 CV * const outercv = CvOUTSIDE(cv);
410 const U32 seq = CvOUTSIDE_SEQ(cv);
411 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
412 SV ** const namepad = AvARRAY(comppad_name);
413 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
414 SV ** const curpad = AvARRAY(comppad);
415 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
416 SV * const namesv = namepad[ix];
417 if (namesv && namesv != &PL_sv_undef
418 && *SvPVX_const(namesv) == '&')
420 CV * const innercv = MUTABLE_CV(curpad[ix]);
421 U32 inner_rc = SvREFCNT(innercv);
423 assert(SvTYPE(innercv) != SVt_PVFM);
425 SvREFCNT_dec(namesv);
427 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
429 SvREFCNT_dec(innercv);
433 /* in use, not just a prototype */
434 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
435 assert(CvWEAKOUTSIDE(innercv));
436 /* don't relink to grandfather if he's being freed */
437 if (outercv && SvREFCNT(outercv)) {
438 CvWEAKOUTSIDE_off(innercv);
439 CvOUTSIDE(innercv) = outercv;
440 CvOUTSIDE_SEQ(innercv) = seq;
441 SvREFCNT_inc_simple_void_NN(outercv);
444 CvOUTSIDE(innercv) = NULL;
451 ix = AvFILLp(padlist);
453 SV* const sv = AvARRAY(padlist)[ix--];
455 if (sv == (const SV *)PL_comppad) {
463 SV *const sv = AvARRAY(padlist)[0];
464 if (sv == (const SV *)PL_comppad_name)
465 PL_comppad_name = NULL;
468 AvREAL_off(CvPADLIST(cv));
469 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
470 CvPADLIST(cv) = NULL;
474 /* remove CvOUTSIDE unless this is an undef rather than a free */
475 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
476 if (!CvWEAKOUTSIDE(cv))
477 SvREFCNT_dec(CvOUTSIDE(cv));
478 CvOUTSIDE(cv) = NULL;
481 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
484 if (CvISXSUB(cv) && CvXSUB(cv)) {
487 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
488 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
489 * to choose an error message */
490 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
493 #ifndef PL_OP_SLAB_ALLOC
495 Perl_cv_forget_slab(pTHX_ CV *cv)
497 const bool slabbed = !!CvSLABBED(cv);
499 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
501 if (!slabbed) return;
505 if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
506 else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
508 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
514 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
516 Allocates a place in the currently-compiling
517 pad (via L<perlapi/pad_alloc>) and
518 then stores a name for that entry. I<namesv> is adopted and becomes the
519 name entry; it must already contain the name string and be sufficiently
520 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
521 added to I<namesv>. None of the other
522 processing of L<perlapi/pad_add_name_pvn>
523 is done. Returns the offset of the allocated pad slot.
529 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
532 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
534 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
536 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
539 assert(SvTYPE(namesv) == SVt_PVMG);
540 SvPAD_TYPED_on(namesv);
541 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
544 SvPAD_OUR_on(namesv);
545 SvOURSTASH_set(namesv, ourstash);
546 SvREFCNT_inc_simple_void_NN(ourstash);
548 else if (flags & padadd_STATE) {
549 SvPAD_STATE_on(namesv);
552 av_store(PL_comppad_name, offset, namesv);
557 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
559 Allocates a place in the currently-compiling pad for a named lexical
560 variable. Stores the name and other metadata in the name part of the
561 pad, and makes preparations to manage the variable's lexical scoping.
562 Returns the offset of the allocated pad slot.
564 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
565 If I<typestash> is non-null, the name is for a typed lexical, and this
566 identifies the type. If I<ourstash> is non-null, it's a lexical reference
567 to a package variable, and this identifies the package. The following
568 flags can be OR'ed together:
570 padadd_OUR redundantly specifies if it's a package var
571 padadd_STATE variable will retain value persistently
572 padadd_NO_DUP_CHECK skip check for lexical shadowing
578 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
579 U32 flags, HV *typestash, HV *ourstash)
586 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
588 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
589 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
592 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
594 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
595 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
598 sv_setpvn(namesv, namepv, namelen);
601 flags |= padadd_UTF8_NAME;
605 flags &= ~padadd_UTF8_NAME;
607 if ((flags & padadd_NO_DUP_CHECK) == 0) {
608 /* check for duplicate declaration */
609 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
612 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
614 /* not yet introduced */
615 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
616 COP_SEQ_RANGE_HIGH_set(namesv, 0);
618 if (!PL_min_intro_pending)
619 PL_min_intro_pending = offset;
620 PL_max_intro_pending = offset;
621 /* if it's not a simple scalar, replace with an AV or HV */
622 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
623 assert(SvREFCNT(PL_curpad[offset]) == 1);
624 if (namelen != 0 && *namepv == '@')
625 sv_upgrade(PL_curpad[offset], SVt_PVAV);
626 else if (namelen != 0 && *namepv == '%')
627 sv_upgrade(PL_curpad[offset], SVt_PVHV);
628 assert(SvPADMY(PL_curpad[offset]));
629 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
630 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
631 (long)offset, SvPVX(namesv),
632 PTR2UV(PL_curpad[offset])));
638 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
640 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
641 instead of a string/length pair.
647 Perl_pad_add_name_pv(pTHX_ const char *name,
648 const U32 flags, HV *typestash, HV *ourstash)
650 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
651 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
655 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
657 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
658 of an SV instead of a string/length pair.
664 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
668 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
669 namepv = SvPV(name, namelen);
671 flags |= padadd_UTF8_NAME;
672 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
676 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
678 Allocates a place in the currently-compiling pad,
679 returning the offset of the allocated pad slot.
680 No name is initially attached to the pad slot.
681 I<tmptype> is a set of flags indicating the kind of pad entry required,
682 which will be set in the value SV for the allocated pad entry:
684 SVs_PADMY named lexical variable ("my", "our", "state")
685 SVs_PADTMP unnamed temporary store
687 I<optype> should be an opcode indicating the type of operation that the
688 pad entry is to support. This doesn't affect operational semantics,
689 but is used for debugging.
694 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
695 * or at least rationalise ??? */
698 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
704 PERL_UNUSED_ARG(optype);
705 ASSERT_CURPAD_ACTIVE("pad_alloc");
707 if (AvARRAY(PL_comppad) != PL_curpad)
708 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
709 AvARRAY(PL_comppad), PL_curpad);
710 if (PL_pad_reset_pending)
712 if (tmptype & SVs_PADMY) {
713 /* For a my, simply push a null SV onto the end of PL_comppad. */
714 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
715 retval = AvFILLp(PL_comppad);
718 /* For a tmp, scan the pad from PL_padix upwards
719 * for a slot which has no name and no active value.
721 SV * const * const names = AvARRAY(PL_comppad_name);
722 const SSize_t names_fill = AvFILLp(PL_comppad_name);
725 * "foreach" index vars temporarily become aliases to non-"my"
726 * values. Thus we must skip, not just pad values that are
727 * marked as current pad values, but also those with names.
729 /* HVDS why copy to sv here? we don't seem to use it */
730 if (++PL_padix <= names_fill &&
731 (sv = names[PL_padix]) && sv != &PL_sv_undef)
733 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
734 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
735 !IS_PADGV(sv) && !IS_PADCONST(sv))
740 SvFLAGS(sv) |= tmptype;
741 PL_curpad = AvARRAY(PL_comppad);
743 DEBUG_X(PerlIO_printf(Perl_debug_log,
744 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
745 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
746 PL_op_name[optype]));
747 #ifdef DEBUG_LEAKING_SCALARS
748 sv->sv_debug_optype = optype;
749 sv->sv_debug_inpad = 1;
751 return (PADOFFSET)retval;
755 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
757 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
758 for an anonymous function that is lexically scoped inside the
759 currently-compiling function.
760 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
761 to the outer scope is weakened to avoid a reference loop.
763 I<optype> should be an opcode indicating the type of operation that the
764 pad entry is to support. This doesn't affect operational semantics,
765 but is used for debugging.
771 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
775 SV* const name = newSV_type(SVt_PVNV);
777 PERL_ARGS_ASSERT_PAD_ADD_ANON;
780 sv_setpvs(name, "&");
781 /* These two aren't used; just make sure they're not equal to
782 * PERL_PADSEQ_INTRO */
783 COP_SEQ_RANGE_LOW_set(name, 0);
784 COP_SEQ_RANGE_HIGH_set(name, 0);
785 ix = pad_alloc(optype, SVs_PADMY);
786 av_store(PL_comppad_name, ix, name);
787 /* XXX DAPM use PL_curpad[] ? */
788 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
789 av_store(PL_comppad, ix, (SV*)func);
791 SV *rv = newRV_inc((SV *)func);
793 assert (SvTYPE(func) == SVt_PVFM);
794 av_store(PL_comppad, ix, rv);
796 SvPADMY_on((SV*)func);
798 /* to avoid ref loops, we never have parent + child referencing each
799 * other simultaneously */
800 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
801 assert(!CvWEAKOUTSIDE(func));
802 CvWEAKOUTSIDE_on(func);
803 SvREFCNT_dec(CvOUTSIDE(func));
809 =for apidoc pad_check_dup
811 Check for duplicate declarations: report any of:
813 * a my in the current scope with the same name;
814 * an our (anywhere in the pad) with the same name and the
815 same stash as C<ourstash>
817 C<is_our> indicates that the name to check is an 'our' declaration.
823 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
828 const U32 is_our = flags & padadd_OUR;
830 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
832 ASSERT_CURPAD_ACTIVE("pad_check_dup");
834 assert((flags & ~padadd_OUR) == 0);
836 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
837 return; /* nothing to check */
839 svp = AvARRAY(PL_comppad_name);
840 top = AvFILLp(PL_comppad_name);
841 /* check the current scope */
842 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
844 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
845 SV * const sv = svp[off];
847 && sv != &PL_sv_undef
849 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
850 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
853 if (is_our && (SvPAD_OUR(sv)))
854 break; /* "our" masking "our" */
855 Perl_warner(aTHX_ packWARN(WARN_MISC),
856 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
857 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
859 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
860 ? "scope" : "statement"));
865 /* check the rest of the pad */
868 SV * const sv = svp[off];
870 && sv != &PL_sv_undef
872 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
873 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
874 && SvOURSTASH(sv) == ourstash
877 Perl_warner(aTHX_ packWARN(WARN_MISC),
878 "\"our\" variable %"SVf" redeclared", sv);
879 if ((I32)off <= PL_comppad_name_floor)
880 Perl_warner(aTHX_ packWARN(WARN_MISC),
881 "\t(Did you mean \"local\" instead of \"our\"?)\n");
891 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
893 Given the name of a lexical variable, find its position in the
894 currently-compiling pad.
895 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
896 I<flags> is reserved and must be zero.
897 If it is not in the current pad but appears in the pad of any lexically
898 enclosing scope, then a pseudo-entry for it is added in the current pad.
899 Returns the offset in the current pad,
900 or C<NOT_IN_PAD> if no such lexical is in scope.
906 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
915 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
917 pad_peg("pad_findmy_pvn");
919 if (flags & ~padadd_UTF8_NAME)
920 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
923 if (flags & padadd_UTF8_NAME) {
925 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
928 flags |= padadd_UTF8_NAME;
930 flags &= ~padadd_UTF8_NAME;
933 offset = pad_findlex(namepv, namelen, flags,
934 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
935 if ((PADOFFSET)offset != NOT_IN_PAD)
938 /* look for an our that's being introduced; this allows
939 * our $foo = 0 unless defined $foo;
940 * to not give a warning. (Yes, this is a hack) */
942 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
943 name_svp = AvARRAY(nameav);
944 for (offset = AvFILLp(nameav); offset > 0; offset--) {
945 const SV * const namesv = name_svp[offset];
946 if (namesv && namesv != &PL_sv_undef
948 && (SvPAD_OUR(namesv))
949 && SvCUR(namesv) == namelen
950 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
951 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
952 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
960 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
962 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
963 instead of a string/length pair.
969 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
971 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
972 return pad_findmy_pvn(name, strlen(name), flags);
976 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
978 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
979 of an SV instead of a string/length pair.
985 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
989 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
990 namepv = SvPV(name, namelen);
992 flags |= padadd_UTF8_NAME;
993 return pad_findmy_pvn(namepv, namelen, flags);
997 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
999 Find the position of the lexical C<$_> in the pad of the
1000 currently-executing function. Returns the offset in the current pad,
1001 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1002 the global one should be used instead).
1003 L</find_rundefsv> is likely to be more convenient.
1009 Perl_find_rundefsvoffset(pTHX)
1014 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1015 NULL, &out_sv, &out_flags);
1019 =for apidoc Am|SV *|find_rundefsv
1021 Find and return the variable that is named C<$_> in the lexical scope
1022 of the currently-executing function. This may be a lexical C<$_>,
1023 or will otherwise be the global one.
1029 Perl_find_rundefsv(pTHX)
1035 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1036 NULL, &namesv, &flags);
1038 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1045 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1051 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1053 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1054 NULL, &namesv, &flags);
1056 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1059 return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1063 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1065 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1066 in the inner pads if it's found in an outer one.
1068 Returns the offset in the bottom pad of the lex or the fake lex.
1069 cv is the CV in which to start the search, and seq is the current cop_seq
1070 to match against. If warn is true, print appropriate warnings. The out_*
1071 vars return values, and so are pointers to where the returned values
1072 should be stored. out_capture, if non-null, requests that the innermost
1073 instance of the lexical is captured; out_name_sv is set to the innermost
1074 matched namesv or fake namesv; out_flags returns the flags normally
1075 associated with the IVX field of a fake namesv.
1077 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1078 then comes back down, adding fake entries as it goes. It has to be this way
1079 because fake namesvs in anon protoypes have to store in xlow the index into
1085 /* the CV has finished being compiled. This is not a sufficient test for
1086 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1087 #define CvCOMPILED(cv) CvROOT(cv)
1089 /* the CV does late binding of its lexicals */
1090 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1094 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1095 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1098 I32 offset, new_offset;
1101 const AV * const padlist = CvPADLIST(cv);
1103 PERL_ARGS_ASSERT_PAD_FINDLEX;
1105 if (flags & ~padadd_UTF8_NAME)
1106 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1111 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1112 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1113 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1114 out_capture ? " capturing" : "" ));
1116 /* first, search this pad */
1118 if (padlist) { /* not an undef CV */
1119 I32 fake_offset = 0;
1120 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1121 SV * const * const name_svp = AvARRAY(nameav);
1123 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1124 const SV * const namesv = name_svp[offset];
1125 if (namesv && namesv != &PL_sv_undef
1126 && SvCUR(namesv) == namelen
1127 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1128 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1130 if (SvFAKE(namesv)) {
1131 fake_offset = offset; /* in case we don't find a real one */
1134 /* is seq within the range _LOW to _HIGH ?
1135 * This is complicated by the fact that PL_cop_seqmax
1136 * may have wrapped around at some point */
1137 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1138 continue; /* not yet introduced */
1140 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1141 /* in compiling scope */
1143 (seq > COP_SEQ_RANGE_LOW(namesv))
1144 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1145 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1150 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1152 ( seq > COP_SEQ_RANGE_LOW(namesv)
1153 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1155 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1156 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1162 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1163 if (offset > 0) { /* not fake */
1165 *out_name_sv = name_svp[offset]; /* return the namesv */
1167 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1168 * instances. For now, we just test !CvUNIQUE(cv), but
1169 * ideally, we should detect my's declared within loops
1170 * etc - this would allow a wider range of 'not stayed
1171 * shared' warnings. We also treated already-compiled
1172 * lexes as not multi as viewed from evals. */
1174 *out_flags = CvANON(cv) ?
1176 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1177 ? PAD_FAKELEX_MULTI : 0;
1179 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1180 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1181 PTR2UV(cv), (long)offset,
1182 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1183 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1185 else { /* fake match */
1186 offset = fake_offset;
1187 *out_name_sv = name_svp[offset]; /* return the namesv */
1188 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1189 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1190 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1191 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1192 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1196 /* return the lex? */
1201 if (SvPAD_OUR(*out_name_sv)) {
1202 *out_capture = NULL;
1206 /* trying to capture from an anon prototype? */
1208 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1209 : *out_flags & PAD_FAKELEX_ANON)
1212 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1213 "Variable \"%"SVf"\" is not available",
1214 newSVpvn_flags(namepv, namelen,
1216 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1218 *out_capture = NULL;
1224 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1225 && !SvPAD_STATE(name_svp[offset])
1226 && warn && ckWARN(WARN_CLOSURE)) {
1228 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1229 "Variable \"%"SVf"\" will not stay shared",
1230 newSVpvn_flags(namepv, namelen,
1232 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1235 if (fake_offset && CvANON(cv)
1236 && CvCLONE(cv) &&!CvCLONED(cv))
1239 /* not yet caught - look further up */
1240 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1241 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1244 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1246 newwarn, out_capture, out_name_sv, out_flags);
1251 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1252 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1253 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1254 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1255 PTR2UV(cv), PTR2UV(*out_capture)));
1257 if (SvPADSTALE(*out_capture)
1258 && !SvPAD_STATE(name_svp[offset]))
1260 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1261 "Variable \"%"SVf"\" is not available",
1262 newSVpvn_flags(namepv, namelen,
1264 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1265 *out_capture = NULL;
1268 if (!*out_capture) {
1269 if (namelen != 0 && *namepv == '@')
1270 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1271 else if (namelen != 0 && *namepv == '%')
1272 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1274 *out_capture = sv_newmortal();
1282 /* it's not in this pad - try above */
1287 /* out_capture non-null means caller wants us to capture lex; in
1288 * addition we capture ourselves unless it's an ANON/format */
1289 new_capturep = out_capture ? out_capture :
1290 CvLATE(cv) ? NULL : &new_capture;
1292 offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1293 new_capturep, out_name_sv, out_flags);
1294 if ((PADOFFSET)offset == NOT_IN_PAD)
1297 /* found in an outer CV. Add appropriate fake entry to this pad */
1299 /* don't add new fake entries (via eval) to CVs that we have already
1300 * finished compiling, or to undef CVs */
1301 if (CvCOMPILED(cv) || !padlist)
1302 return 0; /* this dummy (and invalid) value isnt used by the caller */
1305 /* This relies on sv_setsv_flags() upgrading the destination to the same
1306 type as the source, independent of the flags set, and on it being
1307 "good" and only copying flag bits and pointers that it understands.
1309 SV *new_namesv = newSVsv(*out_name_sv);
1310 AV * const ocomppad_name = PL_comppad_name;
1311 PAD * const ocomppad = PL_comppad;
1312 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1313 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1314 PL_curpad = AvARRAY(PL_comppad);
1317 = pad_alloc_name(new_namesv,
1318 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1319 SvPAD_TYPED(*out_name_sv)
1320 ? SvSTASH(*out_name_sv) : NULL,
1321 SvOURSTASH(*out_name_sv)
1324 SvFAKE_on(new_namesv);
1325 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1326 "Pad addname: %ld \"%.*s\" FAKE\n",
1328 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1329 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1331 PARENT_PAD_INDEX_set(new_namesv, 0);
1332 if (SvPAD_OUR(new_namesv)) {
1333 NOOP; /* do nothing */
1335 else if (CvLATE(cv)) {
1336 /* delayed creation - just note the offset within parent pad */
1337 PARENT_PAD_INDEX_set(new_namesv, offset);
1341 /* immediate creation - capture outer value right now */
1342 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1343 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1344 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1345 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1347 *out_name_sv = new_namesv;
1348 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1350 PL_comppad_name = ocomppad_name;
1351 PL_comppad = ocomppad;
1352 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1360 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1362 Get the value at offset I<po> in the current (compiling or executing) pad.
1363 Use macro PAD_SV instead of calling this function directly.
1369 Perl_pad_sv(pTHX_ PADOFFSET po)
1372 ASSERT_CURPAD_ACTIVE("pad_sv");
1375 Perl_croak(aTHX_ "panic: pad_sv po");
1376 DEBUG_X(PerlIO_printf(Perl_debug_log,
1377 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1378 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1380 return PL_curpad[po];
1384 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1386 Set the value at offset I<po> in the current (compiling or executing) pad.
1387 Use the macro PAD_SETSV() rather than calling this function directly.
1393 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1397 PERL_ARGS_ASSERT_PAD_SETSV;
1399 ASSERT_CURPAD_ACTIVE("pad_setsv");
1401 DEBUG_X(PerlIO_printf(Perl_debug_log,
1402 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1403 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1408 #endif /* DEBUGGING */
1411 =for apidoc m|void|pad_block_start|int full
1413 Update the pad compilation state variables on entry to a new block
1418 /* XXX DAPM perhaps:
1419 * - integrate this in general state-saving routine ???
1420 * - combine with the state-saving going on in pad_new ???
1421 * - introduce a new SAVE type that does all this in one go ?
1425 Perl_pad_block_start(pTHX_ int full)
1428 ASSERT_CURPAD_ACTIVE("pad_block_start");
1429 SAVEI32(PL_comppad_name_floor);
1430 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1432 PL_comppad_name_fill = PL_comppad_name_floor;
1433 if (PL_comppad_name_floor < 0)
1434 PL_comppad_name_floor = 0;
1435 SAVEI32(PL_min_intro_pending);
1436 SAVEI32(PL_max_intro_pending);
1437 PL_min_intro_pending = 0;
1438 SAVEI32(PL_comppad_name_fill);
1439 SAVEI32(PL_padix_floor);
1440 PL_padix_floor = PL_padix;
1441 PL_pad_reset_pending = FALSE;
1445 =for apidoc m|U32|intro_my
1447 "Introduce" my variables to visible status.
1460 ASSERT_CURPAD_ACTIVE("intro_my");
1461 if (! PL_min_intro_pending)
1462 return PL_cop_seqmax;
1464 svp = AvARRAY(PL_comppad_name);
1465 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1466 SV * const sv = svp[i];
1468 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1469 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1471 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1472 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1473 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1474 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1475 (long)i, SvPVX_const(sv),
1476 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1477 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1481 seq = PL_cop_seqmax;
1483 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1485 PL_min_intro_pending = 0;
1486 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1487 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1488 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1494 =for apidoc m|void|pad_leavemy
1496 Cleanup at end of scope during compilation: set the max seq number for
1497 lexicals in this scope and warn of any lexicals that never got introduced.
1503 Perl_pad_leavemy(pTHX)
1507 SV * const * const svp = AvARRAY(PL_comppad_name);
1509 PL_pad_reset_pending = FALSE;
1511 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1512 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1513 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1514 const SV * const sv = svp[off];
1515 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1516 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1517 "%"SVf" never introduced",
1521 /* "Deintroduce" my variables that are leaving with this scope. */
1522 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1523 const SV * const sv = svp[off];
1524 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1525 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1527 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1528 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1529 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1530 (long)off, SvPVX_const(sv),
1531 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1532 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1537 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1544 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1546 Abandon the tmp in the current pad at offset po and replace with a
1553 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1556 ASSERT_CURPAD_LEGAL("pad_swipe");
1559 if (AvARRAY(PL_comppad) != PL_curpad)
1560 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1561 AvARRAY(PL_comppad), PL_curpad);
1562 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1563 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1564 (long)po, (long)AvFILLp(PL_comppad));
1566 DEBUG_X(PerlIO_printf(Perl_debug_log,
1567 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1568 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1571 SvPADTMP_off(PL_curpad[po]);
1573 SvREFCNT_dec(PL_curpad[po]);
1576 /* if pad tmps aren't shared between ops, then there's no need to
1577 * create a new tmp when an existing op is freed */
1578 #ifdef USE_BROKEN_PAD_RESET
1579 PL_curpad[po] = newSV(0);
1580 SvPADTMP_on(PL_curpad[po]);
1582 PL_curpad[po] = &PL_sv_undef;
1584 if ((I32)po < PL_padix)
1589 =for apidoc m|void|pad_reset
1591 Mark all the current temporaries for reuse
1596 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1597 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1598 * on the stack by OPs that use them, there are several ways to get an alias
1599 * to a shared TARG. Such an alias will change randomly and unpredictably.
1600 * We avoid doing this until we can think of a Better Way.
1606 #ifdef USE_BROKEN_PAD_RESET
1607 if (AvARRAY(PL_comppad) != PL_curpad)
1608 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1609 AvARRAY(PL_comppad), PL_curpad);
1611 DEBUG_X(PerlIO_printf(Perl_debug_log,
1612 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1613 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1614 (long)PL_padix, (long)PL_padix_floor
1618 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1620 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1621 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1622 SvPADTMP_off(PL_curpad[po]);
1624 PL_padix = PL_padix_floor;
1627 PL_pad_reset_pending = FALSE;
1631 =for apidoc Amx|void|pad_tidy|padtidy_type type
1633 Tidy up a pad at the end of compilation of the code to which it belongs.
1634 Jobs performed here are: remove most stuff from the pads of anonsub
1635 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1636 the kind of subroutine:
1638 padtidy_SUB ordinary subroutine
1639 padtidy_SUBCLONE prototype for lexical closure
1640 padtidy_FORMAT format
1645 /* XXX DAPM surely most of this stuff should be done properly
1646 * at the right time beforehand, rather than going around afterwards
1647 * cleaning up our mistakes ???
1651 Perl_pad_tidy(pTHX_ padtidy_type type)
1655 ASSERT_CURPAD_ACTIVE("pad_tidy");
1657 /* If this CV has had any 'eval-capable' ops planted in it
1658 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1659 * anon prototypes in the chain of CVs should be marked as cloneable,
1660 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1661 * the right CvOUTSIDE.
1662 * If running with -d, *any* sub may potentially have an eval
1663 * executed within it.
1666 if (PL_cv_has_eval || PL_perldb) {
1668 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1669 if (cv != PL_compcv && CvCOMPILED(cv))
1670 break; /* no need to mark already-compiled code */
1672 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1673 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1680 /* extend curpad to match namepad */
1681 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1682 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1684 if (type == padtidy_SUBCLONE) {
1685 SV * const * const namep = AvARRAY(PL_comppad_name);
1688 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1691 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1694 * The only things that a clonable function needs in its
1695 * pad are anonymous subs.
1696 * The rest are created anew during cloning.
1698 if (!((namesv = namep[ix]) != NULL &&
1699 namesv != &PL_sv_undef &&
1700 *SvPVX_const(namesv) == '&'))
1702 SvREFCNT_dec(PL_curpad[ix]);
1703 PL_curpad[ix] = NULL;
1707 else if (type == padtidy_SUB) {
1708 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1709 AV * const av = newAV(); /* Will be @_ */
1710 av_store(PL_comppad, 0, MUTABLE_SV(av));
1714 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1715 SV * const * const namep = AvARRAY(PL_comppad_name);
1717 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1718 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1720 if (!SvPADMY(PL_curpad[ix])) {
1721 SvPADTMP_on(PL_curpad[ix]);
1722 } else if (!SvFAKE(namep[ix])) {
1723 /* This is a work around for how the current implementation of
1724 ?{ } blocks in regexps interacts with lexicals.
1726 One of our lexicals.
1727 Can't do this on all lexicals, otherwise sub baz() won't
1736 because completion of compiling &bar calling pad_tidy()
1737 would cause (top level) $foo to be marked as stale, and
1738 "no longer available". */
1739 SvPADSTALE_on(PL_curpad[ix]);
1743 PL_curpad = AvARRAY(PL_comppad);
1747 =for apidoc m|void|pad_free|PADOFFSET po
1749 Free the SV at offset po in the current pad.
1754 /* XXX DAPM integrate with pad_swipe ???? */
1756 Perl_pad_free(pTHX_ PADOFFSET po)
1759 ASSERT_CURPAD_LEGAL("pad_free");
1762 if (AvARRAY(PL_comppad) != PL_curpad)
1763 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1764 AvARRAY(PL_comppad), PL_curpad);
1766 Perl_croak(aTHX_ "panic: pad_free po");
1768 DEBUG_X(PerlIO_printf(Perl_debug_log,
1769 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1770 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1773 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1774 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1776 if ((I32)po < PL_padix)
1781 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1783 Dump the contents of a padlist
1789 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1798 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1803 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1804 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1805 pname = AvARRAY(pad_name);
1806 ppad = AvARRAY(pad);
1807 Perl_dump_indent(aTHX_ level, file,
1808 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1809 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1812 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1813 const SV *namesv = pname[ix];
1814 if (namesv && namesv == &PL_sv_undef) {
1819 Perl_dump_indent(aTHX_ level+1, file,
1820 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1823 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1824 SvPVX_const(namesv),
1825 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1826 (unsigned long)PARENT_PAD_INDEX(namesv)
1830 Perl_dump_indent(aTHX_ level+1, file,
1831 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1834 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1835 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1836 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1841 Perl_dump_indent(aTHX_ level+1, file,
1842 "%2d. 0x%"UVxf"<%lu>\n",
1845 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1854 =for apidoc m|void|cv_dump|CV *cv|const char *title
1856 dump the contents of a CV
1862 S_cv_dump(pTHX_ const CV *cv, const char *title)
1865 const CV * const outside = CvOUTSIDE(cv);
1866 AV* const padlist = CvPADLIST(cv);
1868 PERL_ARGS_ASSERT_CV_DUMP;
1870 PerlIO_printf(Perl_debug_log,
1871 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1874 (CvANON(cv) ? "ANON"
1875 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1876 : (cv == PL_main_cv) ? "MAIN"
1877 : CvUNIQUE(cv) ? "UNIQUE"
1878 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1881 : CvANON(outside) ? "ANON"
1882 : (outside == PL_main_cv) ? "MAIN"
1883 : CvUNIQUE(outside) ? "UNIQUE"
1884 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1886 PerlIO_printf(Perl_debug_log,
1887 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1888 do_dump_pad(1, Perl_debug_log, padlist, 1);
1891 #endif /* DEBUGGING */
1894 =for apidoc Am|CV *|cv_clone|CV *proto
1896 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1897 of the function: its code, pad structure, and other attributes.
1898 The prototype is combined with a capture of outer lexicals to which the
1899 code refers, which are taken from the currently-executing instance of
1900 the immediately surrounding code.
1906 Perl_cv_clone(pTHX_ CV *proto)
1910 AV* const protopadlist = CvPADLIST(proto);
1911 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1912 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1913 SV** const pname = AvARRAY(protopad_name);
1914 SV** const ppad = AvARRAY(protopad);
1915 const I32 fname = AvFILLp(protopad_name);
1916 const I32 fpad = AvFILLp(protopad);
1922 PERL_ARGS_ASSERT_CV_CLONE;
1924 assert(!CvUNIQUE(proto));
1926 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1927 * to a prototype; we instead want the cloned parent who called us.
1928 * Note that in general for formats, CvOUTSIDE != find_runcv; formats
1929 * inside closures, however, only work if CvOUTSIDE == find_runcv.
1932 outside = CvOUTSIDE(proto);
1933 if (!outside || (CvCLONE(outside) && ! CvCLONED(outside)))
1934 outside = find_runcv(NULL);
1935 if (SvTYPE(proto) == SVt_PVFM
1936 && CvROOT(outside) != CvROOT(CvOUTSIDE(proto)))
1937 outside = CvOUTSIDE(proto);
1938 depth = CvDEPTH(outside);
1939 assert(depth || SvTYPE(proto) == SVt_PVFM);
1942 assert(CvPADLIST(outside));
1945 SAVESPTR(PL_compcv);
1947 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1948 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1952 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1954 CvGV_set(cv,CvGV(proto));
1955 CvSTASH_set(cv, CvSTASH(proto));
1957 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1959 CvSTART(cv) = CvSTART(proto);
1961 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1962 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1965 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1967 mg_copy((SV *)proto, (SV *)cv, 0, 0);
1969 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1971 av_fill(PL_comppad, fpad);
1972 for (ix = fname; ix > 0; ix--)
1973 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1975 PL_curpad = AvARRAY(PL_comppad);
1977 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1979 for (ix = fpad; ix > 0; ix--) {
1980 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1982 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1983 if (SvFAKE(namesv)) { /* lexical from outside? */
1984 sv = outpad[PARENT_PAD_INDEX(namesv)];
1985 /* formats may have an inactive parent,
1986 while my $x if $false can leave an active var marked as
1987 stale. And state vars are always available */
1988 if (!sv || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
1989 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1990 "Variable \"%"SVf"\" is not available", namesv);
1994 SvREFCNT_inc_simple_void_NN(sv);
1997 const char sigil = SvPVX_const(namesv)[0];
1999 sv = SvREFCNT_inc(ppad[ix]);
2000 else if (sigil == '@')
2001 sv = MUTABLE_SV(newAV());
2002 else if (sigil == '%')
2003 sv = MUTABLE_SV(newHV());
2007 /* reset the 'assign only once' flag on each state var */
2008 if (SvPAD_STATE(namesv))
2012 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2013 sv = SvREFCNT_inc_NN(ppad[ix]);
2023 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2024 cv_dump(outside, "Outside");
2025 cv_dump(proto, "Proto");
2032 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2033 * The prototype was marked as a candiate for const-ization,
2034 * so try to grab the current const value, and if successful,
2035 * turn into a const sub:
2037 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2040 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2051 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2053 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2054 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2055 moved to a pre-existing CV struct.
2061 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2065 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2066 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2067 SV ** const namepad = AvARRAY(comppad_name);
2068 SV ** const curpad = AvARRAY(comppad);
2070 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2071 PERL_UNUSED_ARG(old_cv);
2073 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2074 const SV * const namesv = namepad[ix];
2075 if (namesv && namesv != &PL_sv_undef
2076 && *SvPVX_const(namesv) == '&')
2078 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2079 CV * const innercv = MUTABLE_CV(curpad[ix]);
2080 assert(CvWEAKOUTSIDE(innercv));
2081 assert(CvOUTSIDE(innercv) == old_cv);
2082 CvOUTSIDE(innercv) = new_cv;
2084 else { /* format reference */
2085 SV * const rv = curpad[ix];
2087 if (!SvOK(rv)) continue;
2089 assert(SvWEAKREF(rv));
2090 innercv = (CV *)SvRV(rv);
2091 assert(!CvWEAKOUTSIDE(innercv));
2092 SvREFCNT_dec(CvOUTSIDE(innercv));
2093 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2100 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2102 Push a new pad frame onto the padlist, unless there's already a pad at
2103 this depth, in which case don't bother creating a new one. Then give
2104 the new pad an @_ in slot zero.
2110 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2114 PERL_ARGS_ASSERT_PAD_PUSH;
2116 if (depth > AvFILLp(padlist)) {
2117 SV** const svp = AvARRAY(padlist);
2118 AV* const newpad = newAV();
2119 SV** const oldpad = AvARRAY(svp[depth-1]);
2120 I32 ix = AvFILLp((const AV *)svp[1]);
2121 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2122 SV** const names = AvARRAY(svp[0]);
2125 for ( ;ix > 0; ix--) {
2126 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2127 const char sigil = SvPVX_const(names[ix])[0];
2128 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2129 || (SvFLAGS(names[ix]) & SVpad_STATE)
2132 /* outer lexical or anon code */
2133 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2135 else { /* our own lexical */
2138 sv = MUTABLE_SV(newAV());
2139 else if (sigil == '%')
2140 sv = MUTABLE_SV(newHV());
2143 av_store(newpad, ix, sv);
2147 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2148 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2151 /* save temporaries on recursion? */
2152 SV * const sv = newSV(0);
2153 av_store(newpad, ix, sv);
2158 av_store(newpad, 0, MUTABLE_SV(av));
2161 av_store(padlist, depth, MUTABLE_SV(newpad));
2162 AvFILLp(padlist) = depth;
2167 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2169 Looks up the type of the lexical variable at position I<po> in the
2170 currently-compiling pad. If the variable is typed, the stash of the
2171 class to which it is typed is returned. If not, C<NULL> is returned.
2177 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2180 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2181 if ( SvPAD_TYPED(*av) ) {
2182 return SvSTASH(*av);
2187 #if defined(USE_ITHREADS)
2189 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2192 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2200 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2203 PERL_ARGS_ASSERT_PADLIST_DUP;
2208 if (param->flags & CLONEf_COPY_STACKS
2209 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2210 dstpad = av_dup_inc(srcpad, param);
2211 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2213 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2214 to build anything other than the first level of pads. */
2216 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2218 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2219 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2220 SV **oldpad = AvARRAY(srcpad1);
2224 /* Look for it in the table first, as the padlist may have ended up
2225 as an element of @DB::args (or theoretically even @_), so it may
2226 may have been cloned already. */
2227 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2230 return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2233 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2234 av_extend(dstpad, 1);
2235 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2236 names = AvARRAY(AvARRAY(dstpad)[0]);
2240 av_extend(pad1, ix);
2241 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2242 pad1a = AvARRAY(pad1);
2243 AvFILLp(dstpad) = 1;
2248 for ( ;ix > 0; ix--) {
2251 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2252 const char sigil = SvPVX_const(names[ix])[0];
2253 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2254 || (SvFLAGS(names[ix]) & SVpad_STATE)
2257 /* outer lexical or anon code */
2258 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2260 else { /* our own lexical */
2261 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2262 /* This is a work around for how the current
2263 implementation of ?{ } blocks in regexps
2264 interacts with lexicals. */
2265 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2270 sv = MUTABLE_SV(newAV());
2271 else if (sigil == '%')
2272 sv = MUTABLE_SV(newHV());
2280 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2281 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2284 /* save temporaries on recursion? */
2285 SV * const sv = newSV(0);
2288 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2289 FIXTHAT before merging this branch.
2290 (And I know how to) */
2291 if (SvPADMY(oldpad[ix]))
2299 args = newAV(); /* Will be @_ */
2301 pad1a[0] = (SV *)args;
2309 #endif /* USE_ITHREADS */
2313 * c-indentation-style: bsd
2315 * indent-tabs-mode: nil
2318 * ex: set ts=8 sts=4 sw=4 et: