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 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
364 else if (slabbed && CvSTART(cv)) {
366 PAD_SAVE_SETNULLPAD();
368 /* discard any leaked ops */
369 opslab_force_free((OPSLAB *)CvSTART(cv));
375 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
377 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
380 /* This statement and the subsequence if block was pad_undef(). */
381 pad_peg("pad_undef");
383 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
387 /* Free the padlist associated with a CV.
388 If parts of it happen to be current, we null the relevant PL_*pad*
389 global vars so that we don't have any dangling references left.
390 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
391 subs to the outer of this cv. */
393 DEBUG_X(PerlIO_printf(Perl_debug_log,
394 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
395 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
398 /* detach any '&' anon children in the pad; if afterwards they
399 * are still live, fix up their CvOUTSIDEs to point to our outside,
401 /* XXX DAPM for efficiency, we should only do this if we know we have
402 * children, or integrate this loop with general cleanup */
404 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
405 CV * const outercv = CvOUTSIDE(cv);
406 const U32 seq = CvOUTSIDE_SEQ(cv);
407 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
408 SV ** const namepad = AvARRAY(comppad_name);
409 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
410 SV ** const curpad = AvARRAY(comppad);
411 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
412 SV * const namesv = namepad[ix];
413 if (namesv && namesv != &PL_sv_undef
414 && *SvPVX_const(namesv) == '&')
416 CV * const innercv = MUTABLE_CV(curpad[ix]);
417 U32 inner_rc = SvREFCNT(innercv);
419 assert(SvTYPE(innercv) != SVt_PVFM);
421 SvREFCNT_dec(namesv);
423 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
425 SvREFCNT_dec(innercv);
429 /* in use, not just a prototype */
430 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
431 assert(CvWEAKOUTSIDE(innercv));
432 /* don't relink to grandfather if he's being freed */
433 if (outercv && SvREFCNT(outercv)) {
434 CvWEAKOUTSIDE_off(innercv);
435 CvOUTSIDE(innercv) = outercv;
436 CvOUTSIDE_SEQ(innercv) = seq;
437 SvREFCNT_inc_simple_void_NN(outercv);
440 CvOUTSIDE(innercv) = NULL;
447 ix = AvFILLp(padlist);
449 SV* const sv = AvARRAY(padlist)[ix--];
451 if (sv == (const SV *)PL_comppad) {
459 SV *const sv = AvARRAY(padlist)[0];
460 if (sv == (const SV *)PL_comppad_name)
461 PL_comppad_name = NULL;
464 AvREAL_off(CvPADLIST(cv));
465 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
466 CvPADLIST(cv) = NULL;
470 /* remove CvOUTSIDE unless this is an undef rather than a free */
471 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
472 if (!CvWEAKOUTSIDE(cv))
473 SvREFCNT_dec(CvOUTSIDE(cv));
474 CvOUTSIDE(cv) = NULL;
477 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
480 if (CvISXSUB(cv) && CvXSUB(cv)) {
483 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
484 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
485 * to choose an error message */
486 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
490 Perl_cv_forget_slab(pTHX_ CV *cv)
492 const bool slabbed = !!CvSLABBED(cv);
493 #ifdef PERL_DEBUG_READONLY_OPS
497 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
499 if (!slabbed) return;
503 #ifdef PERL_DEBUG_READONLY_OPS
504 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
505 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
507 if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
508 else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
511 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
514 #ifdef PERL_DEBUG_READONLY_OPS
517 refcnt = slab->opslab_refcnt;
518 OpslabREFCNT_dec(slab);
519 if (refcnt > 1) Slab_to_ro(slab);
525 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
527 Allocates a place in the currently-compiling
528 pad (via L<perlapi/pad_alloc>) and
529 then stores a name for that entry. I<namesv> is adopted and becomes the
530 name entry; it must already contain the name string and be sufficiently
531 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
532 added to I<namesv>. None of the other
533 processing of L<perlapi/pad_add_name_pvn>
534 is done. Returns the offset of the allocated pad slot.
540 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
543 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
545 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
547 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
550 assert(SvTYPE(namesv) == SVt_PVMG);
551 SvPAD_TYPED_on(namesv);
552 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
555 SvPAD_OUR_on(namesv);
556 SvOURSTASH_set(namesv, ourstash);
557 SvREFCNT_inc_simple_void_NN(ourstash);
559 else if (flags & padadd_STATE) {
560 SvPAD_STATE_on(namesv);
563 av_store(PL_comppad_name, offset, namesv);
568 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
570 Allocates a place in the currently-compiling pad for a named lexical
571 variable. Stores the name and other metadata in the name part of the
572 pad, and makes preparations to manage the variable's lexical scoping.
573 Returns the offset of the allocated pad slot.
575 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
576 If I<typestash> is non-null, the name is for a typed lexical, and this
577 identifies the type. If I<ourstash> is non-null, it's a lexical reference
578 to a package variable, and this identifies the package. The following
579 flags can be OR'ed together:
581 padadd_OUR redundantly specifies if it's a package var
582 padadd_STATE variable will retain value persistently
583 padadd_NO_DUP_CHECK skip check for lexical shadowing
589 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
590 U32 flags, HV *typestash, HV *ourstash)
597 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
599 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
600 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
603 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
605 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
606 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
609 sv_setpvn(namesv, namepv, namelen);
612 flags |= padadd_UTF8_NAME;
616 flags &= ~padadd_UTF8_NAME;
618 if ((flags & padadd_NO_DUP_CHECK) == 0) {
619 /* check for duplicate declaration */
620 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
623 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
625 /* not yet introduced */
626 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
627 COP_SEQ_RANGE_HIGH_set(namesv, 0);
629 if (!PL_min_intro_pending)
630 PL_min_intro_pending = offset;
631 PL_max_intro_pending = offset;
632 /* if it's not a simple scalar, replace with an AV or HV */
633 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
634 assert(SvREFCNT(PL_curpad[offset]) == 1);
635 if (namelen != 0 && *namepv == '@')
636 sv_upgrade(PL_curpad[offset], SVt_PVAV);
637 else if (namelen != 0 && *namepv == '%')
638 sv_upgrade(PL_curpad[offset], SVt_PVHV);
639 assert(SvPADMY(PL_curpad[offset]));
640 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
641 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
642 (long)offset, SvPVX(namesv),
643 PTR2UV(PL_curpad[offset])));
649 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
651 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
652 instead of a string/length pair.
658 Perl_pad_add_name_pv(pTHX_ const char *name,
659 const U32 flags, HV *typestash, HV *ourstash)
661 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
662 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
666 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
668 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
669 of an SV instead of a string/length pair.
675 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
679 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
680 namepv = SvPV(name, namelen);
682 flags |= padadd_UTF8_NAME;
683 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
687 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
689 Allocates a place in the currently-compiling pad,
690 returning the offset of the allocated pad slot.
691 No name is initially attached to the pad slot.
692 I<tmptype> is a set of flags indicating the kind of pad entry required,
693 which will be set in the value SV for the allocated pad entry:
695 SVs_PADMY named lexical variable ("my", "our", "state")
696 SVs_PADTMP unnamed temporary store
698 I<optype> should be an opcode indicating the type of operation that the
699 pad entry is to support. This doesn't affect operational semantics,
700 but is used for debugging.
705 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
706 * or at least rationalise ??? */
709 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
715 PERL_UNUSED_ARG(optype);
716 ASSERT_CURPAD_ACTIVE("pad_alloc");
718 if (AvARRAY(PL_comppad) != PL_curpad)
719 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
720 AvARRAY(PL_comppad), PL_curpad);
721 if (PL_pad_reset_pending)
723 if (tmptype & SVs_PADMY) {
724 /* For a my, simply push a null SV onto the end of PL_comppad. */
725 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
726 retval = AvFILLp(PL_comppad);
729 /* For a tmp, scan the pad from PL_padix upwards
730 * for a slot which has no name and no active value.
732 SV * const * const names = AvARRAY(PL_comppad_name);
733 const SSize_t names_fill = AvFILLp(PL_comppad_name);
736 * "foreach" index vars temporarily become aliases to non-"my"
737 * values. Thus we must skip, not just pad values that are
738 * marked as current pad values, but also those with names.
740 /* HVDS why copy to sv here? we don't seem to use it */
741 if (++PL_padix <= names_fill &&
742 (sv = names[PL_padix]) && sv != &PL_sv_undef)
744 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
745 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
746 !IS_PADGV(sv) && !IS_PADCONST(sv))
751 SvFLAGS(sv) |= tmptype;
752 PL_curpad = AvARRAY(PL_comppad);
754 DEBUG_X(PerlIO_printf(Perl_debug_log,
755 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
756 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
757 PL_op_name[optype]));
758 #ifdef DEBUG_LEAKING_SCALARS
759 sv->sv_debug_optype = optype;
760 sv->sv_debug_inpad = 1;
762 return (PADOFFSET)retval;
766 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
768 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
769 for an anonymous function that is lexically scoped inside the
770 currently-compiling function.
771 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
772 to the outer scope is weakened to avoid a reference loop.
774 I<optype> should be an opcode indicating the type of operation that the
775 pad entry is to support. This doesn't affect operational semantics,
776 but is used for debugging.
782 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
786 SV* const name = newSV_type(SVt_PVNV);
788 PERL_ARGS_ASSERT_PAD_ADD_ANON;
791 sv_setpvs(name, "&");
792 /* These two aren't used; just make sure they're not equal to
793 * PERL_PADSEQ_INTRO */
794 COP_SEQ_RANGE_LOW_set(name, 0);
795 COP_SEQ_RANGE_HIGH_set(name, 0);
796 ix = pad_alloc(optype, SVs_PADMY);
797 av_store(PL_comppad_name, ix, name);
798 /* XXX DAPM use PL_curpad[] ? */
799 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
800 av_store(PL_comppad, ix, (SV*)func);
802 SV *rv = newRV_inc((SV *)func);
804 assert (SvTYPE(func) == SVt_PVFM);
805 av_store(PL_comppad, ix, rv);
807 SvPADMY_on((SV*)func);
809 /* to avoid ref loops, we never have parent + child referencing each
810 * other simultaneously */
811 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
812 assert(!CvWEAKOUTSIDE(func));
813 CvWEAKOUTSIDE_on(func);
814 SvREFCNT_dec(CvOUTSIDE(func));
820 =for apidoc pad_check_dup
822 Check for duplicate declarations: report any of:
824 * a my in the current scope with the same name;
825 * an our (anywhere in the pad) with the same name and the
826 same stash as C<ourstash>
828 C<is_our> indicates that the name to check is an 'our' declaration.
834 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
839 const U32 is_our = flags & padadd_OUR;
841 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
843 ASSERT_CURPAD_ACTIVE("pad_check_dup");
845 assert((flags & ~padadd_OUR) == 0);
847 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
848 return; /* nothing to check */
850 svp = AvARRAY(PL_comppad_name);
851 top = AvFILLp(PL_comppad_name);
852 /* check the current scope */
853 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
855 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
856 SV * const sv = svp[off];
858 && sv != &PL_sv_undef
860 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
861 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
864 if (is_our && (SvPAD_OUR(sv)))
865 break; /* "our" masking "our" */
866 Perl_warner(aTHX_ packWARN(WARN_MISC),
867 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
868 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
870 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
871 ? "scope" : "statement"));
876 /* check the rest of the pad */
879 SV * const sv = svp[off];
881 && sv != &PL_sv_undef
883 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
884 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
885 && SvOURSTASH(sv) == ourstash
888 Perl_warner(aTHX_ packWARN(WARN_MISC),
889 "\"our\" variable %"SVf" redeclared", sv);
890 if ((I32)off <= PL_comppad_name_floor)
891 Perl_warner(aTHX_ packWARN(WARN_MISC),
892 "\t(Did you mean \"local\" instead of \"our\"?)\n");
902 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
904 Given the name of a lexical variable, find its position in the
905 currently-compiling pad.
906 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
907 I<flags> is reserved and must be zero.
908 If it is not in the current pad but appears in the pad of any lexically
909 enclosing scope, then a pseudo-entry for it is added in the current pad.
910 Returns the offset in the current pad,
911 or C<NOT_IN_PAD> if no such lexical is in scope.
917 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
926 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
928 pad_peg("pad_findmy_pvn");
930 if (flags & ~padadd_UTF8_NAME)
931 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
934 if (flags & padadd_UTF8_NAME) {
936 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
939 flags |= padadd_UTF8_NAME;
941 flags &= ~padadd_UTF8_NAME;
944 offset = pad_findlex(namepv, namelen, flags,
945 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
946 if ((PADOFFSET)offset != NOT_IN_PAD)
949 /* look for an our that's being introduced; this allows
950 * our $foo = 0 unless defined $foo;
951 * to not give a warning. (Yes, this is a hack) */
953 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
954 name_svp = AvARRAY(nameav);
955 for (offset = AvFILLp(nameav); offset > 0; offset--) {
956 const SV * const namesv = name_svp[offset];
957 if (namesv && namesv != &PL_sv_undef
959 && (SvPAD_OUR(namesv))
960 && SvCUR(namesv) == namelen
961 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
962 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
963 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
971 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
973 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
974 instead of a string/length pair.
980 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
982 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
983 return pad_findmy_pvn(name, strlen(name), flags);
987 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
989 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
990 of an SV instead of a string/length pair.
996 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1000 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1001 namepv = SvPV(name, namelen);
1003 flags |= padadd_UTF8_NAME;
1004 return pad_findmy_pvn(namepv, namelen, flags);
1008 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1010 Find the position of the lexical C<$_> in the pad of the
1011 currently-executing function. Returns the offset in the current pad,
1012 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1013 the global one should be used instead).
1014 L</find_rundefsv> is likely to be more convenient.
1020 Perl_find_rundefsvoffset(pTHX)
1025 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1026 NULL, &out_sv, &out_flags);
1030 =for apidoc Am|SV *|find_rundefsv
1032 Find and return the variable that is named C<$_> in the lexical scope
1033 of the currently-executing function. This may be a lexical C<$_>,
1034 or will otherwise be the global one.
1040 Perl_find_rundefsv(pTHX)
1046 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1047 NULL, &namesv, &flags);
1049 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1056 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1062 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1064 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1065 NULL, &namesv, &flags);
1067 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1070 return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1074 =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
1076 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1077 in the inner pads if it's found in an outer one.
1079 Returns the offset in the bottom pad of the lex or the fake lex.
1080 cv is the CV in which to start the search, and seq is the current cop_seq
1081 to match against. If warn is true, print appropriate warnings. The out_*
1082 vars return values, and so are pointers to where the returned values
1083 should be stored. out_capture, if non-null, requests that the innermost
1084 instance of the lexical is captured; out_name_sv is set to the innermost
1085 matched namesv or fake namesv; out_flags returns the flags normally
1086 associated with the IVX field of a fake namesv.
1088 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1089 then comes back down, adding fake entries as it goes. It has to be this way
1090 because fake namesvs in anon protoypes have to store in xlow the index into
1096 /* the CV has finished being compiled. This is not a sufficient test for
1097 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1098 #define CvCOMPILED(cv) CvROOT(cv)
1100 /* the CV does late binding of its lexicals */
1101 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1105 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1106 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1109 I32 offset, new_offset;
1112 const AV * const padlist = CvPADLIST(cv);
1114 PERL_ARGS_ASSERT_PAD_FINDLEX;
1116 if (flags & ~padadd_UTF8_NAME)
1117 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1122 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1123 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1124 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1125 out_capture ? " capturing" : "" ));
1127 /* first, search this pad */
1129 if (padlist) { /* not an undef CV */
1130 I32 fake_offset = 0;
1131 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1132 SV * const * const name_svp = AvARRAY(nameav);
1134 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1135 const SV * const namesv = name_svp[offset];
1136 if (namesv && namesv != &PL_sv_undef
1137 && SvCUR(namesv) == namelen
1138 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1139 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1141 if (SvFAKE(namesv)) {
1142 fake_offset = offset; /* in case we don't find a real one */
1145 /* is seq within the range _LOW to _HIGH ?
1146 * This is complicated by the fact that PL_cop_seqmax
1147 * may have wrapped around at some point */
1148 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1149 continue; /* not yet introduced */
1151 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1152 /* in compiling scope */
1154 (seq > COP_SEQ_RANGE_LOW(namesv))
1155 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1156 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1161 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1163 ( seq > COP_SEQ_RANGE_LOW(namesv)
1164 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1166 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1167 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1173 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1174 if (offset > 0) { /* not fake */
1176 *out_name_sv = name_svp[offset]; /* return the namesv */
1178 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1179 * instances. For now, we just test !CvUNIQUE(cv), but
1180 * ideally, we should detect my's declared within loops
1181 * etc - this would allow a wider range of 'not stayed
1182 * shared' warnings. We also treated already-compiled
1183 * lexes as not multi as viewed from evals. */
1185 *out_flags = CvANON(cv) ?
1187 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1188 ? PAD_FAKELEX_MULTI : 0;
1190 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1191 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1192 PTR2UV(cv), (long)offset,
1193 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1194 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1196 else { /* fake match */
1197 offset = fake_offset;
1198 *out_name_sv = name_svp[offset]; /* return the namesv */
1199 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1200 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1201 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1202 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1203 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1207 /* return the lex? */
1212 if (SvPAD_OUR(*out_name_sv)) {
1213 *out_capture = NULL;
1217 /* trying to capture from an anon prototype? */
1219 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1220 : *out_flags & PAD_FAKELEX_ANON)
1223 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1224 "Variable \"%"SVf"\" is not available",
1225 newSVpvn_flags(namepv, namelen,
1227 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1229 *out_capture = NULL;
1235 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1236 && !SvPAD_STATE(name_svp[offset])
1237 && warn && ckWARN(WARN_CLOSURE)) {
1239 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1240 "Variable \"%"SVf"\" will not stay shared",
1241 newSVpvn_flags(namepv, namelen,
1243 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1246 if (fake_offset && CvANON(cv)
1247 && CvCLONE(cv) &&!CvCLONED(cv))
1250 /* not yet caught - look further up */
1251 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1252 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1255 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1257 newwarn, out_capture, out_name_sv, out_flags);
1262 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1263 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1264 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1265 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1266 PTR2UV(cv), PTR2UV(*out_capture)));
1268 if (SvPADSTALE(*out_capture)
1269 && !SvPAD_STATE(name_svp[offset]))
1271 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1272 "Variable \"%"SVf"\" is not available",
1273 newSVpvn_flags(namepv, namelen,
1275 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1276 *out_capture = NULL;
1279 if (!*out_capture) {
1280 if (namelen != 0 && *namepv == '@')
1281 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1282 else if (namelen != 0 && *namepv == '%')
1283 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1285 *out_capture = sv_newmortal();
1293 /* it's not in this pad - try above */
1298 /* out_capture non-null means caller wants us to capture lex; in
1299 * addition we capture ourselves unless it's an ANON/format */
1300 new_capturep = out_capture ? out_capture :
1301 CvLATE(cv) ? NULL : &new_capture;
1303 offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1304 new_capturep, out_name_sv, out_flags);
1305 if ((PADOFFSET)offset == NOT_IN_PAD)
1308 /* found in an outer CV. Add appropriate fake entry to this pad */
1310 /* don't add new fake entries (via eval) to CVs that we have already
1311 * finished compiling, or to undef CVs */
1312 if (CvCOMPILED(cv) || !padlist)
1313 return 0; /* this dummy (and invalid) value isnt used by the caller */
1316 /* This relies on sv_setsv_flags() upgrading the destination to the same
1317 type as the source, independent of the flags set, and on it being
1318 "good" and only copying flag bits and pointers that it understands.
1320 SV *new_namesv = newSVsv(*out_name_sv);
1321 AV * const ocomppad_name = PL_comppad_name;
1322 PAD * const ocomppad = PL_comppad;
1323 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1324 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1325 PL_curpad = AvARRAY(PL_comppad);
1328 = pad_alloc_name(new_namesv,
1329 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1330 SvPAD_TYPED(*out_name_sv)
1331 ? SvSTASH(*out_name_sv) : NULL,
1332 SvOURSTASH(*out_name_sv)
1335 SvFAKE_on(new_namesv);
1336 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1337 "Pad addname: %ld \"%.*s\" FAKE\n",
1339 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1340 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1342 PARENT_PAD_INDEX_set(new_namesv, 0);
1343 if (SvPAD_OUR(new_namesv)) {
1344 NOOP; /* do nothing */
1346 else if (CvLATE(cv)) {
1347 /* delayed creation - just note the offset within parent pad */
1348 PARENT_PAD_INDEX_set(new_namesv, offset);
1352 /* immediate creation - capture outer value right now */
1353 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1354 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1355 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1356 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1358 *out_name_sv = new_namesv;
1359 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1361 PL_comppad_name = ocomppad_name;
1362 PL_comppad = ocomppad;
1363 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1371 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1373 Get the value at offset I<po> in the current (compiling or executing) pad.
1374 Use macro PAD_SV instead of calling this function directly.
1380 Perl_pad_sv(pTHX_ PADOFFSET po)
1383 ASSERT_CURPAD_ACTIVE("pad_sv");
1386 Perl_croak(aTHX_ "panic: pad_sv po");
1387 DEBUG_X(PerlIO_printf(Perl_debug_log,
1388 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1389 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1391 return PL_curpad[po];
1395 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1397 Set the value at offset I<po> in the current (compiling or executing) pad.
1398 Use the macro PAD_SETSV() rather than calling this function directly.
1404 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1408 PERL_ARGS_ASSERT_PAD_SETSV;
1410 ASSERT_CURPAD_ACTIVE("pad_setsv");
1412 DEBUG_X(PerlIO_printf(Perl_debug_log,
1413 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1414 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1419 #endif /* DEBUGGING */
1422 =for apidoc m|void|pad_block_start|int full
1424 Update the pad compilation state variables on entry to a new block
1429 /* XXX DAPM perhaps:
1430 * - integrate this in general state-saving routine ???
1431 * - combine with the state-saving going on in pad_new ???
1432 * - introduce a new SAVE type that does all this in one go ?
1436 Perl_pad_block_start(pTHX_ int full)
1439 ASSERT_CURPAD_ACTIVE("pad_block_start");
1440 SAVEI32(PL_comppad_name_floor);
1441 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1443 PL_comppad_name_fill = PL_comppad_name_floor;
1444 if (PL_comppad_name_floor < 0)
1445 PL_comppad_name_floor = 0;
1446 SAVEI32(PL_min_intro_pending);
1447 SAVEI32(PL_max_intro_pending);
1448 PL_min_intro_pending = 0;
1449 SAVEI32(PL_comppad_name_fill);
1450 SAVEI32(PL_padix_floor);
1451 PL_padix_floor = PL_padix;
1452 PL_pad_reset_pending = FALSE;
1456 =for apidoc m|U32|intro_my
1458 "Introduce" my variables to visible status. This is called during parsing
1459 at the end of each statement to make lexical variables visible to
1460 subsequent statements.
1473 ASSERT_CURPAD_ACTIVE("intro_my");
1474 if (! PL_min_intro_pending)
1475 return PL_cop_seqmax;
1477 svp = AvARRAY(PL_comppad_name);
1478 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1479 SV * const sv = svp[i];
1481 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1482 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1484 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1485 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1486 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1487 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1488 (long)i, SvPVX_const(sv),
1489 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1490 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1494 seq = PL_cop_seqmax;
1496 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1498 PL_min_intro_pending = 0;
1499 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1500 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1501 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1507 =for apidoc m|void|pad_leavemy
1509 Cleanup at end of scope during compilation: set the max seq number for
1510 lexicals in this scope and warn of any lexicals that never got introduced.
1516 Perl_pad_leavemy(pTHX)
1520 SV * const * const svp = AvARRAY(PL_comppad_name);
1522 PL_pad_reset_pending = FALSE;
1524 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1525 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1526 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1527 const SV * const sv = svp[off];
1528 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1529 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1530 "%"SVf" never introduced",
1534 /* "Deintroduce" my variables that are leaving with this scope. */
1535 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1536 const SV * const sv = svp[off];
1537 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1538 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1540 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1541 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1542 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1543 (long)off, SvPVX_const(sv),
1544 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1545 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1550 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1552 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1553 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1557 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1559 Abandon the tmp in the current pad at offset po and replace with a
1566 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1569 ASSERT_CURPAD_LEGAL("pad_swipe");
1572 if (AvARRAY(PL_comppad) != PL_curpad)
1573 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1574 AvARRAY(PL_comppad), PL_curpad);
1575 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1576 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1577 (long)po, (long)AvFILLp(PL_comppad));
1579 DEBUG_X(PerlIO_printf(Perl_debug_log,
1580 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1581 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1584 SvPADTMP_off(PL_curpad[po]);
1586 SvREFCNT_dec(PL_curpad[po]);
1589 /* if pad tmps aren't shared between ops, then there's no need to
1590 * create a new tmp when an existing op is freed */
1591 #ifdef USE_BROKEN_PAD_RESET
1592 PL_curpad[po] = newSV(0);
1593 SvPADTMP_on(PL_curpad[po]);
1595 PL_curpad[po] = &PL_sv_undef;
1597 if ((I32)po < PL_padix)
1602 =for apidoc m|void|pad_reset
1604 Mark all the current temporaries for reuse
1609 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1610 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1611 * on the stack by OPs that use them, there are several ways to get an alias
1612 * to a shared TARG. Such an alias will change randomly and unpredictably.
1613 * We avoid doing this until we can think of a Better Way.
1619 #ifdef USE_BROKEN_PAD_RESET
1620 if (AvARRAY(PL_comppad) != PL_curpad)
1621 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1622 AvARRAY(PL_comppad), PL_curpad);
1624 DEBUG_X(PerlIO_printf(Perl_debug_log,
1625 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1626 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1627 (long)PL_padix, (long)PL_padix_floor
1631 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1633 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1634 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1635 SvPADTMP_off(PL_curpad[po]);
1637 PL_padix = PL_padix_floor;
1640 PL_pad_reset_pending = FALSE;
1644 =for apidoc Amx|void|pad_tidy|padtidy_type type
1646 Tidy up a pad at the end of compilation of the code to which it belongs.
1647 Jobs performed here are: remove most stuff from the pads of anonsub
1648 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1649 the kind of subroutine:
1651 padtidy_SUB ordinary subroutine
1652 padtidy_SUBCLONE prototype for lexical closure
1653 padtidy_FORMAT format
1658 /* XXX DAPM surely most of this stuff should be done properly
1659 * at the right time beforehand, rather than going around afterwards
1660 * cleaning up our mistakes ???
1664 Perl_pad_tidy(pTHX_ padtidy_type type)
1668 ASSERT_CURPAD_ACTIVE("pad_tidy");
1670 /* If this CV has had any 'eval-capable' ops planted in it
1671 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1672 * anon prototypes in the chain of CVs should be marked as cloneable,
1673 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1674 * the right CvOUTSIDE.
1675 * If running with -d, *any* sub may potentially have an eval
1676 * executed within it.
1679 if (PL_cv_has_eval || PL_perldb) {
1681 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1682 if (cv != PL_compcv && CvCOMPILED(cv))
1683 break; /* no need to mark already-compiled code */
1685 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1686 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1693 /* extend curpad to match namepad */
1694 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1695 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1697 if (type == padtidy_SUBCLONE) {
1698 SV * const * const namep = AvARRAY(PL_comppad_name);
1701 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1704 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1707 * The only things that a clonable function needs in its
1708 * pad are anonymous subs.
1709 * The rest are created anew during cloning.
1711 if (!((namesv = namep[ix]) != NULL &&
1712 namesv != &PL_sv_undef &&
1713 *SvPVX_const(namesv) == '&'))
1715 SvREFCNT_dec(PL_curpad[ix]);
1716 PL_curpad[ix] = NULL;
1720 else if (type == padtidy_SUB) {
1721 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1722 AV * const av = newAV(); /* Will be @_ */
1723 av_store(PL_comppad, 0, MUTABLE_SV(av));
1727 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1728 SV * const * const namep = AvARRAY(PL_comppad_name);
1730 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1731 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1733 if (!SvPADMY(PL_curpad[ix])) {
1734 SvPADTMP_on(PL_curpad[ix]);
1735 } else if (!SvFAKE(namep[ix])) {
1736 /* This is a work around for how the current implementation of
1737 ?{ } blocks in regexps interacts with lexicals.
1739 One of our lexicals.
1740 Can't do this on all lexicals, otherwise sub baz() won't
1749 because completion of compiling &bar calling pad_tidy()
1750 would cause (top level) $foo to be marked as stale, and
1751 "no longer available". */
1752 SvPADSTALE_on(PL_curpad[ix]);
1756 PL_curpad = AvARRAY(PL_comppad);
1760 =for apidoc m|void|pad_free|PADOFFSET po
1762 Free the SV at offset po in the current pad.
1767 /* XXX DAPM integrate with pad_swipe ???? */
1769 Perl_pad_free(pTHX_ PADOFFSET po)
1772 ASSERT_CURPAD_LEGAL("pad_free");
1775 if (AvARRAY(PL_comppad) != PL_curpad)
1776 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1777 AvARRAY(PL_comppad), PL_curpad);
1779 Perl_croak(aTHX_ "panic: pad_free po");
1781 DEBUG_X(PerlIO_printf(Perl_debug_log,
1782 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1783 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1786 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1787 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1789 if ((I32)po < PL_padix)
1794 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1796 Dump the contents of a padlist
1802 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1811 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1816 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1817 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1818 pname = AvARRAY(pad_name);
1819 ppad = AvARRAY(pad);
1820 Perl_dump_indent(aTHX_ level, file,
1821 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1822 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1825 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1826 const SV *namesv = pname[ix];
1827 if (namesv && namesv == &PL_sv_undef) {
1832 Perl_dump_indent(aTHX_ level+1, file,
1833 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1836 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1837 SvPVX_const(namesv),
1838 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1839 (unsigned long)PARENT_PAD_INDEX(namesv)
1843 Perl_dump_indent(aTHX_ level+1, file,
1844 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1847 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1848 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1849 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1854 Perl_dump_indent(aTHX_ level+1, file,
1855 "%2d. 0x%"UVxf"<%lu>\n",
1858 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1867 =for apidoc m|void|cv_dump|CV *cv|const char *title
1869 dump the contents of a CV
1875 S_cv_dump(pTHX_ const CV *cv, const char *title)
1878 const CV * const outside = CvOUTSIDE(cv);
1879 AV* const padlist = CvPADLIST(cv);
1881 PERL_ARGS_ASSERT_CV_DUMP;
1883 PerlIO_printf(Perl_debug_log,
1884 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1887 (CvANON(cv) ? "ANON"
1888 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1889 : (cv == PL_main_cv) ? "MAIN"
1890 : CvUNIQUE(cv) ? "UNIQUE"
1891 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1894 : CvANON(outside) ? "ANON"
1895 : (outside == PL_main_cv) ? "MAIN"
1896 : CvUNIQUE(outside) ? "UNIQUE"
1897 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1899 PerlIO_printf(Perl_debug_log,
1900 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1901 do_dump_pad(1, Perl_debug_log, padlist, 1);
1904 #endif /* DEBUGGING */
1907 =for apidoc Am|CV *|cv_clone|CV *proto
1909 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1910 of the function: its code, pad structure, and other attributes.
1911 The prototype is combined with a capture of outer lexicals to which the
1912 code refers, which are taken from the currently-executing instance of
1913 the immediately surrounding code.
1919 Perl_cv_clone(pTHX_ CV *proto)
1923 AV* const protopadlist = CvPADLIST(proto);
1924 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1925 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1926 SV** const pname = AvARRAY(protopad_name);
1927 SV** const ppad = AvARRAY(protopad);
1928 const I32 fname = AvFILLp(protopad_name);
1929 const I32 fpad = AvFILLp(protopad);
1935 PERL_ARGS_ASSERT_CV_CLONE;
1937 assert(!CvUNIQUE(proto));
1939 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1940 * reliable. The currently-running sub is always the one we need to
1942 * Note that in general for formats, CvOUTSIDE != find_runcv.
1943 * Since formats may be nested inside closures, CvOUTSIDE may point
1944 * to a prototype; we instead want the cloned parent who called us.
1947 if (SvTYPE(proto) == SVt_PVCV)
1948 outside = find_runcv(NULL);
1950 outside = CvOUTSIDE(proto);
1951 if (CvCLONE(outside) && ! CvCLONED(outside)) {
1952 CV * const runcv = find_runcv_where(
1953 FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
1955 if (runcv) outside = runcv;
1958 depth = CvDEPTH(outside);
1959 assert(depth || SvTYPE(proto) == SVt_PVFM);
1962 assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
1965 SAVESPTR(PL_compcv);
1967 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1968 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1972 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1974 CvGV_set(cv,CvGV(proto));
1975 CvSTASH_set(cv, CvSTASH(proto));
1977 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1979 CvSTART(cv) = CvSTART(proto);
1981 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1982 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1985 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1987 mg_copy((SV *)proto, (SV *)cv, 0, 0);
1989 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1991 av_fill(PL_comppad, fpad);
1992 for (ix = fname; ix > 0; ix--)
1993 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1995 PL_curpad = AvARRAY(PL_comppad);
1997 outpad = CvPADLIST(outside)
1998 ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
2001 for (ix = fpad; ix > 0; ix--) {
2002 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2004 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2005 if (SvFAKE(namesv)) { /* lexical from outside? */
2006 /* formats may have an inactive, or even undefined, parent,
2007 while my $x if $false can leave an active var marked as
2008 stale. And state vars are always available */
2009 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2010 || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
2011 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2012 "Variable \"%"SVf"\" is not available", namesv);
2016 SvREFCNT_inc_simple_void_NN(sv);
2019 const char sigil = SvPVX_const(namesv)[0];
2021 sv = SvREFCNT_inc(ppad[ix]);
2022 else if (sigil == '@')
2023 sv = MUTABLE_SV(newAV());
2024 else if (sigil == '%')
2025 sv = MUTABLE_SV(newHV());
2029 /* reset the 'assign only once' flag on each state var */
2030 if (SvPAD_STATE(namesv))
2034 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2035 sv = SvREFCNT_inc_NN(ppad[ix]);
2045 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2046 cv_dump(outside, "Outside");
2047 cv_dump(proto, "Proto");
2054 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2055 * The prototype was marked as a candiate for const-ization,
2056 * so try to grab the current const value, and if successful,
2057 * turn into a const sub:
2059 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2062 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2073 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2075 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2076 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2077 moved to a pre-existing CV struct.
2083 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2087 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2088 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2089 SV ** const namepad = AvARRAY(comppad_name);
2090 SV ** const curpad = AvARRAY(comppad);
2092 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2093 PERL_UNUSED_ARG(old_cv);
2095 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2096 const SV * const namesv = namepad[ix];
2097 if (namesv && namesv != &PL_sv_undef
2098 && *SvPVX_const(namesv) == '&')
2100 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2101 CV * const innercv = MUTABLE_CV(curpad[ix]);
2102 assert(CvWEAKOUTSIDE(innercv));
2103 assert(CvOUTSIDE(innercv) == old_cv);
2104 CvOUTSIDE(innercv) = new_cv;
2106 else { /* format reference */
2107 SV * const rv = curpad[ix];
2109 if (!SvOK(rv)) continue;
2111 assert(SvWEAKREF(rv));
2112 innercv = (CV *)SvRV(rv);
2113 assert(!CvWEAKOUTSIDE(innercv));
2114 SvREFCNT_dec(CvOUTSIDE(innercv));
2115 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2122 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2124 Push a new pad frame onto the padlist, unless there's already a pad at
2125 this depth, in which case don't bother creating a new one. Then give
2126 the new pad an @_ in slot zero.
2132 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2136 PERL_ARGS_ASSERT_PAD_PUSH;
2138 if (depth > AvFILLp(padlist)) {
2139 SV** const svp = AvARRAY(padlist);
2140 AV* const newpad = newAV();
2141 SV** const oldpad = AvARRAY(svp[depth-1]);
2142 I32 ix = AvFILLp((const AV *)svp[1]);
2143 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2144 SV** const names = AvARRAY(svp[0]);
2147 for ( ;ix > 0; ix--) {
2148 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2149 const char sigil = SvPVX_const(names[ix])[0];
2150 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2151 || (SvFLAGS(names[ix]) & SVpad_STATE)
2154 /* outer lexical or anon code */
2155 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2157 else { /* our own lexical */
2160 sv = MUTABLE_SV(newAV());
2161 else if (sigil == '%')
2162 sv = MUTABLE_SV(newHV());
2165 av_store(newpad, ix, sv);
2169 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2170 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2173 /* save temporaries on recursion? */
2174 SV * const sv = newSV(0);
2175 av_store(newpad, ix, sv);
2180 av_store(newpad, 0, MUTABLE_SV(av));
2183 av_store(padlist, depth, MUTABLE_SV(newpad));
2184 AvFILLp(padlist) = depth;
2189 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2191 Looks up the type of the lexical variable at position I<po> in the
2192 currently-compiling pad. If the variable is typed, the stash of the
2193 class to which it is typed is returned. If not, C<NULL> is returned.
2199 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2202 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2203 if ( SvPAD_TYPED(*av) ) {
2204 return SvSTASH(*av);
2209 #if defined(USE_ITHREADS)
2211 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2214 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2222 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2225 PERL_ARGS_ASSERT_PADLIST_DUP;
2230 if (param->flags & CLONEf_COPY_STACKS
2231 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2232 dstpad = av_dup_inc(srcpad, param);
2233 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2235 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2236 to build anything other than the first level of pads. */
2238 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2240 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2241 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2242 SV **oldpad = AvARRAY(srcpad1);
2246 /* Look for it in the table first, as the padlist may have ended up
2247 as an element of @DB::args (or theoretically even @_), so it may
2248 may have been cloned already. */
2249 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2252 return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2255 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2256 av_extend(dstpad, 1);
2257 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2258 names = AvARRAY(AvARRAY(dstpad)[0]);
2262 av_extend(pad1, ix);
2263 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2264 pad1a = AvARRAY(pad1);
2265 AvFILLp(dstpad) = 1;
2270 for ( ;ix > 0; ix--) {
2273 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2274 const char sigil = SvPVX_const(names[ix])[0];
2275 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2276 || (SvFLAGS(names[ix]) & SVpad_STATE)
2279 /* outer lexical or anon code */
2280 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2282 else { /* our own lexical */
2283 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2284 /* This is a work around for how the current
2285 implementation of ?{ } blocks in regexps
2286 interacts with lexicals. */
2287 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2292 sv = MUTABLE_SV(newAV());
2293 else if (sigil == '%')
2294 sv = MUTABLE_SV(newHV());
2302 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2303 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2306 /* save temporaries on recursion? */
2307 SV * const sv = newSV(0);
2310 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2311 FIXTHAT before merging this branch.
2312 (And I know how to) */
2313 if (SvPADMY(oldpad[ix]))
2321 args = newAV(); /* Will be @_ */
2323 pad1a[0] = (SV *)args;
2331 #endif /* USE_ITHREADS */
2335 * c-indentation-style: bsd
2337 * indent-tabs-mode: nil
2340 * ex: set ts=8 sts=4 sw=4 et: