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 a PADLIST. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "formats" 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 PADLIST has a C array where pads are stored.
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals. The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it. See L<PADLIST_NAMES>.
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV. The 0th slot of a frame AV is an
56 AV which is @_. Other entries are storage for variables and op targets.
58 Iterating over the PADNAMELIST 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 (SvPADMY/PADNAME_isOUR) 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"" the way
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 the PAD
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
107 'Variable $x is not available' warning
108 to be generated in evals, such as
110 { my $x = 1; sub f { eval '$x'} } f();
112 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
114 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
116 During compilation, this points to the array containing the names part
117 of the pad for the currently-compiling code.
119 =for apidoc AmxU|PAD *|PL_comppad
121 During compilation, this points to the array containing the values
122 part of the pad for the currently-compiling code. (At runtime a CV may
123 have many such value arrays; at compile time just one is constructed.)
124 At runtime, this points to the array containing the currently-relevant
125 values for the pad for the currently-executing code.
127 =for apidoc AmxU|SV **|PL_curpad
129 Points directly to the body of the L</PL_comppad> array.
130 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
137 #define PERL_IN_PAD_C
139 #include "keywords.h"
141 #define COP_SEQ_RANGE_LOW_set(sv,val) \
142 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
143 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
144 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
146 #define PARENT_PAD_INDEX_set(sv,val) \
147 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
148 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
152 =for apidoc mx|void|pad_peg|const char *s
154 When PERL_MAD is enabled, this is a small no-op function that gets called
155 at the start of each pad-related function. It can be breakpointed to
156 track all pad operations. The parameter is a string indicating the type
157 of pad operation being performed.
163 void pad_peg(const char* s) {
164 static int pegcnt; /* XXX not threadsafe */
167 PERL_ARGS_ASSERT_PAD_PEG;
174 This is basically sv_eq_flags() in sv.c, but we avoid the magic
179 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
180 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
181 const char *pv1 = SvPVX_const(sv);
182 STRLEN cur1 = SvCUR(sv);
183 const char *pv2 = pv;
188 svrecode = newSVpvn(pv2, cur2);
189 sv_recode_to_utf8(svrecode, PL_encoding);
190 pv2 = SvPV_const(svrecode, cur2);
193 svrecode = newSVpvn(pv1, cur1);
194 sv_recode_to_utf8(svrecode, PL_encoding);
195 pv1 = SvPV_const(svrecode, cur1);
197 SvREFCNT_dec(svrecode);
199 if (flags & SVf_UTF8)
200 return (bytes_cmp_utf8(
201 (const U8*)pv1, cur1,
202 (const U8*)pv2, cur2) == 0);
204 return (bytes_cmp_utf8(
205 (const U8*)pv2, cur2,
206 (const U8*)pv1, cur1) == 0);
209 return ((SvPVX_const(sv) == pv)
210 || memEQ(SvPVX_const(sv), pv, pvlen));
215 =for apidoc Am|PADLIST *|pad_new|int flags
217 Create a new padlist, updating the global variables for the
218 currently-compiling padlist to point to the new padlist. The following
219 flags can be OR'ed together:
221 padnew_CLONE this pad is for a cloned CV
222 padnew_SAVE save old globals on the save stack
223 padnew_SAVESUB also save extra stuff for start of sub
229 Perl_pad_new(pTHX_ int flags)
236 ASSERT_CURPAD_LEGAL("pad_new");
238 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
239 * vars (based on flags) rather than storing vals + addresses for
240 * each individually. Also see pad_block_start.
241 * XXX DAPM Try to see whether all these conditionals are required
244 /* save existing state, ... */
246 if (flags & padnew_SAVE) {
248 SAVESPTR(PL_comppad_name);
249 if (! (flags & padnew_CLONE)) {
251 SAVEI32(PL_comppad_name_fill);
252 SAVEI32(PL_min_intro_pending);
253 SAVEI32(PL_max_intro_pending);
254 SAVEBOOL(PL_cv_has_eval);
255 if (flags & padnew_SAVESUB) {
256 SAVEBOOL(PL_pad_reset_pending);
260 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
261 * saved - check at some pt that this is okay */
263 /* ... create new pad ... */
265 Newxz(padlist, 1, PADLIST);
269 if (flags & padnew_CLONE) {
270 /* XXX DAPM I dont know why cv_clone needs it
271 * doing differently yet - perhaps this separate branch can be
272 * dispensed with eventually ???
275 AV * const a0 = newAV(); /* will be @_ */
276 av_store(pad, 0, MUTABLE_SV(a0));
280 padlist->xpadl_id = PL_padlist_generation++;
281 av_store(pad, 0, NULL);
284 /* Most subroutines never recurse, hence only need 2 entries in the padlist
285 array - names, and depth=1. The default for av_store() is to allocate
286 0..3, and even an explicit call to av_extend() with <3 will be rounded
287 up, so we inline the allocation of the array here. */
289 PADLIST_MAX(padlist) = 1;
290 PADLIST_ARRAY(padlist) = ary;
294 /* ... then update state variables */
296 PL_comppad_name = padname;
298 PL_curpad = AvARRAY(pad);
300 if (! (flags & padnew_CLONE)) {
301 PL_comppad_name_fill = 0;
302 PL_min_intro_pending = 0;
307 DEBUG_X(PerlIO_printf(Perl_debug_log,
308 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
309 " name=0x%"UVxf" flags=0x%"UVxf"\n",
310 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
311 PTR2UV(padname), (UV)flags
315 return (PADLIST*)padlist;
320 =head1 Embedding Functions
324 Clear out all the active components of a CV. This can happen either
325 by an explicit C<undef &foo>, or by the reference count going to zero.
326 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
327 children can still follow the full lexical scope chain.
333 Perl_cv_undef(pTHX_ CV *cv)
336 const PADLIST *padlist = CvPADLIST(cv);
337 bool const slabbed = !!CvSLABBED(cv);
339 PERL_ARGS_ASSERT_CV_UNDEF;
341 DEBUG_X(PerlIO_printf(Perl_debug_log,
342 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
343 PTR2UV(cv), PTR2UV(PL_comppad))
346 if (CvFILE(cv) && CvDYNFILE(cv)) {
347 Safefree(CvFILE(cv));
352 if (!CvISXSUB(cv) && CvROOT(cv)) {
353 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
354 Perl_croak(aTHX_ "Can't undef active subroutine");
357 PAD_SAVE_SETNULLPAD();
359 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
365 else if (slabbed && CvSTART(cv)) {
367 PAD_SAVE_SETNULLPAD();
369 /* discard any leaked ops */
370 opslab_force_free((OPSLAB *)CvSTART(cv));
376 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
378 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
379 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
382 /* This statement and the subsequence if block was pad_undef(). */
383 pad_peg("pad_undef");
388 /* Free the padlist associated with a CV.
389 If parts of it happen to be current, we null the relevant PL_*pad*
390 global vars so that we don't have any dangling references left.
391 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
392 subs to the outer of this cv. */
394 DEBUG_X(PerlIO_printf(Perl_debug_log,
395 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
396 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
399 /* detach any '&' anon children in the pad; if afterwards they
400 * are still live, fix up their CvOUTSIDEs to point to our outside,
402 /* XXX DAPM for efficiency, we should only do this if we know we have
403 * children, or integrate this loop with general cleanup */
405 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
406 CV * const outercv = CvOUTSIDE(cv);
407 const U32 seq = CvOUTSIDE_SEQ(cv);
408 PAD * const comppad_name = PADLIST_ARRAY(padlist)[0];
409 SV ** const namepad = AvARRAY(comppad_name);
410 PAD * const comppad = PADLIST_ARRAY(padlist)[1];
411 SV ** const curpad = AvARRAY(comppad);
412 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
413 SV * const namesv = namepad[ix];
414 if (namesv && namesv != &PL_sv_undef
415 && *SvPVX_const(namesv) == '&')
417 CV * const innercv = MUTABLE_CV(curpad[ix]);
418 U32 inner_rc = SvREFCNT(innercv);
420 assert(SvTYPE(innercv) != SVt_PVFM);
422 SvREFCNT_dec(namesv);
424 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
426 SvREFCNT_dec(innercv);
430 /* in use, not just a prototype */
431 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
432 assert(CvWEAKOUTSIDE(innercv));
433 /* don't relink to grandfather if he's being freed */
434 if (outercv && SvREFCNT(outercv)) {
435 CvWEAKOUTSIDE_off(innercv);
436 CvOUTSIDE(innercv) = outercv;
437 CvOUTSIDE_SEQ(innercv) = seq;
438 SvREFCNT_inc_simple_void_NN(outercv);
441 CvOUTSIDE(innercv) = NULL;
448 ix = PADLIST_MAX(padlist);
450 PAD * const sv = PADLIST_ARRAY(padlist)[ix--];
452 if (sv == PL_comppad) {
460 PAD * const sv = PADLIST_ARRAY(padlist)[0];
461 if (sv == PL_comppad_name)
462 PL_comppad_name = NULL;
465 if (PADLIST_ARRAY(padlist)) Safefree(PADLIST_ARRAY(padlist));
467 CvPADLIST(cv) = NULL;
471 /* remove CvOUTSIDE unless this is an undef rather than a free */
472 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
473 if (!CvWEAKOUTSIDE(cv))
474 SvREFCNT_dec(CvOUTSIDE(cv));
475 CvOUTSIDE(cv) = NULL;
478 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
481 if (CvISXSUB(cv) && CvXSUB(cv)) {
484 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
485 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
486 * to choose an error message */
487 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
491 =for apidoc cv_forget_slab
493 When a CV has a reference count on its slab (CvSLABBED), it is responsible
494 for making sure it is freed. (Hence, no two CVs should ever have a
495 reference count on the same slab.) The CV only needs to reference the slab
496 during compilation. Once it is compiled and CvROOT attached, it has
497 finished its job, so it can forget the slab.
503 Perl_cv_forget_slab(pTHX_ CV *cv)
505 const bool slabbed = !!CvSLABBED(cv);
506 #ifdef PERL_DEBUG_READONLY_OPS
510 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
512 if (!slabbed) return;
516 #ifdef PERL_DEBUG_READONLY_OPS
517 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
518 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
520 if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
521 else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
524 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
527 #ifdef PERL_DEBUG_READONLY_OPS
530 refcnt = slab->opslab_refcnt;
531 OpslabREFCNT_dec(slab);
532 if (refcnt > 1) Slab_to_ro(slab);
538 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
540 Allocates a place in the currently-compiling
541 pad (via L<perlapi/pad_alloc>) and
542 then stores a name for that entry. I<namesv> is adopted and becomes the
543 name entry; it must already contain the name string and be sufficiently
544 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
545 added to I<namesv>. None of the other
546 processing of L<perlapi/pad_add_name_pvn>
547 is done. Returns the offset of the allocated pad slot.
553 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
556 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
558 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
560 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
563 assert(SvTYPE(namesv) == SVt_PVMG);
564 SvPAD_TYPED_on(namesv);
565 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
568 SvPAD_OUR_on(namesv);
569 SvOURSTASH_set(namesv, ourstash);
570 SvREFCNT_inc_simple_void_NN(ourstash);
572 else if (flags & padadd_STATE) {
573 SvPAD_STATE_on(namesv);
576 av_store(PL_comppad_name, offset, namesv);
581 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
583 Allocates a place in the currently-compiling pad for a named lexical
584 variable. Stores the name and other metadata in the name part of the
585 pad, and makes preparations to manage the variable's lexical scoping.
586 Returns the offset of the allocated pad slot.
588 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
589 If I<typestash> is non-null, the name is for a typed lexical, and this
590 identifies the type. If I<ourstash> is non-null, it's a lexical reference
591 to a package variable, and this identifies the package. The following
592 flags can be OR'ed together:
594 padadd_OUR redundantly specifies if it's a package var
595 padadd_STATE variable will retain value persistently
596 padadd_NO_DUP_CHECK skip check for lexical shadowing
602 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
603 U32 flags, HV *typestash, HV *ourstash)
610 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
612 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
613 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
616 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
618 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
619 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
622 sv_setpvn(namesv, namepv, namelen);
625 flags |= padadd_UTF8_NAME;
629 flags &= ~padadd_UTF8_NAME;
631 if ((flags & padadd_NO_DUP_CHECK) == 0) {
632 /* check for duplicate declaration */
633 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
636 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
638 /* not yet introduced */
639 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
640 COP_SEQ_RANGE_HIGH_set(namesv, 0);
642 if (!PL_min_intro_pending)
643 PL_min_intro_pending = offset;
644 PL_max_intro_pending = offset;
645 /* if it's not a simple scalar, replace with an AV or HV */
646 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
647 assert(SvREFCNT(PL_curpad[offset]) == 1);
648 if (namelen != 0 && *namepv == '@')
649 sv_upgrade(PL_curpad[offset], SVt_PVAV);
650 else if (namelen != 0 && *namepv == '%')
651 sv_upgrade(PL_curpad[offset], SVt_PVHV);
652 assert(SvPADMY(PL_curpad[offset]));
653 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
654 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
655 (long)offset, SvPVX(namesv),
656 PTR2UV(PL_curpad[offset])));
662 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
664 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
665 instead of a string/length pair.
671 Perl_pad_add_name_pv(pTHX_ const char *name,
672 const U32 flags, HV *typestash, HV *ourstash)
674 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
675 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
679 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
681 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
682 of an SV instead of a string/length pair.
688 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
692 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
693 namepv = SvPV(name, namelen);
695 flags |= padadd_UTF8_NAME;
696 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
700 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
702 Allocates a place in the currently-compiling pad,
703 returning the offset of the allocated pad slot.
704 No name is initially attached to the pad slot.
705 I<tmptype> is a set of flags indicating the kind of pad entry required,
706 which will be set in the value SV for the allocated pad entry:
708 SVs_PADMY named lexical variable ("my", "our", "state")
709 SVs_PADTMP unnamed temporary store
711 I<optype> should be an opcode indicating the type of operation that the
712 pad entry is to support. This doesn't affect operational semantics,
713 but is used for debugging.
718 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
719 * or at least rationalise ??? */
722 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
728 PERL_UNUSED_ARG(optype);
729 ASSERT_CURPAD_ACTIVE("pad_alloc");
731 if (AvARRAY(PL_comppad) != PL_curpad)
732 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
733 AvARRAY(PL_comppad), PL_curpad);
734 if (PL_pad_reset_pending)
736 if (tmptype & SVs_PADMY) {
737 /* For a my, simply push a null SV onto the end of PL_comppad. */
738 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
739 retval = AvFILLp(PL_comppad);
742 /* For a tmp, scan the pad from PL_padix upwards
743 * for a slot which has no name and no active value.
745 SV * const * const names = AvARRAY(PL_comppad_name);
746 const SSize_t names_fill = AvFILLp(PL_comppad_name);
749 * "foreach" index vars temporarily become aliases to non-"my"
750 * values. Thus we must skip, not just pad values that are
751 * marked as current pad values, but also those with names.
753 /* HVDS why copy to sv here? we don't seem to use it */
754 if (++PL_padix <= names_fill &&
755 (sv = names[PL_padix]) && sv != &PL_sv_undef)
757 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
758 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
759 !IS_PADGV(sv) && !IS_PADCONST(sv))
764 SvFLAGS(sv) |= tmptype;
765 PL_curpad = AvARRAY(PL_comppad);
767 DEBUG_X(PerlIO_printf(Perl_debug_log,
768 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
769 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
770 PL_op_name[optype]));
771 #ifdef DEBUG_LEAKING_SCALARS
772 sv->sv_debug_optype = optype;
773 sv->sv_debug_inpad = 1;
775 return (PADOFFSET)retval;
779 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
781 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
782 for an anonymous function that is lexically scoped inside the
783 currently-compiling function.
784 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
785 to the outer scope is weakened to avoid a reference loop.
787 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
789 I<optype> should be an opcode indicating the type of operation that the
790 pad entry is to support. This doesn't affect operational semantics,
791 but is used for debugging.
797 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
801 SV* const name = newSV_type(SVt_PVNV);
803 PERL_ARGS_ASSERT_PAD_ADD_ANON;
806 sv_setpvs(name, "&");
807 /* These two aren't used; just make sure they're not equal to
808 * PERL_PADSEQ_INTRO */
809 COP_SEQ_RANGE_LOW_set(name, 0);
810 COP_SEQ_RANGE_HIGH_set(name, 0);
811 ix = pad_alloc(optype, SVs_PADMY);
812 av_store(PL_comppad_name, ix, name);
813 /* XXX DAPM use PL_curpad[] ? */
814 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
815 av_store(PL_comppad, ix, (SV*)func);
817 SV *rv = newRV_noinc((SV *)func);
819 assert (SvTYPE(func) == SVt_PVFM);
820 av_store(PL_comppad, ix, rv);
822 SvPADMY_on((SV*)func);
824 /* to avoid ref loops, we never have parent + child referencing each
825 * other simultaneously */
826 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
827 assert(!CvWEAKOUTSIDE(func));
828 CvWEAKOUTSIDE_on(func);
829 SvREFCNT_dec(CvOUTSIDE(func));
835 =for apidoc pad_check_dup
837 Check for duplicate declarations: report any of:
839 * a my in the current scope with the same name;
840 * an our (anywhere in the pad) with the same name and the
841 same stash as C<ourstash>
843 C<is_our> indicates that the name to check is an 'our' declaration.
849 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
854 const U32 is_our = flags & padadd_OUR;
856 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
858 ASSERT_CURPAD_ACTIVE("pad_check_dup");
860 assert((flags & ~padadd_OUR) == 0);
862 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
863 return; /* nothing to check */
865 svp = AvARRAY(PL_comppad_name);
866 top = AvFILLp(PL_comppad_name);
867 /* check the current scope */
868 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
870 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
871 SV * const sv = svp[off];
873 && sv != &PL_sv_undef
875 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
876 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
879 if (is_our && (SvPAD_OUR(sv)))
880 break; /* "our" masking "our" */
881 Perl_warner(aTHX_ packWARN(WARN_MISC),
882 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
883 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
885 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
886 ? "scope" : "statement"));
891 /* check the rest of the pad */
894 SV * const sv = svp[off];
896 && sv != &PL_sv_undef
898 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
899 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
900 && SvOURSTASH(sv) == ourstash
903 Perl_warner(aTHX_ packWARN(WARN_MISC),
904 "\"our\" variable %"SVf" redeclared", sv);
905 if ((I32)off <= PL_comppad_name_floor)
906 Perl_warner(aTHX_ packWARN(WARN_MISC),
907 "\t(Did you mean \"local\" instead of \"our\"?)\n");
917 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
919 Given the name of a lexical variable, find its position in the
920 currently-compiling pad.
921 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
922 I<flags> is reserved and must be zero.
923 If it is not in the current pad but appears in the pad of any lexically
924 enclosing scope, then a pseudo-entry for it is added in the current pad.
925 Returns the offset in the current pad,
926 or C<NOT_IN_PAD> if no such lexical is in scope.
932 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
941 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
943 pad_peg("pad_findmy_pvn");
945 if (flags & ~padadd_UTF8_NAME)
946 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
949 if (flags & padadd_UTF8_NAME) {
951 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
954 flags |= padadd_UTF8_NAME;
956 flags &= ~padadd_UTF8_NAME;
959 offset = pad_findlex(namepv, namelen, flags,
960 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
961 if ((PADOFFSET)offset != NOT_IN_PAD)
964 /* look for an our that's being introduced; this allows
965 * our $foo = 0 unless defined $foo;
966 * to not give a warning. (Yes, this is a hack) */
968 nameav = PADLIST_ARRAY(CvPADLIST(PL_compcv))[0];
969 name_svp = AvARRAY(nameav);
970 for (offset = AvFILLp(nameav); offset > 0; offset--) {
971 const SV * const namesv = name_svp[offset];
972 if (namesv && namesv != &PL_sv_undef
974 && (SvPAD_OUR(namesv))
975 && SvCUR(namesv) == namelen
976 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
977 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
978 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
986 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
988 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
989 instead of a string/length pair.
995 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
997 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
998 return pad_findmy_pvn(name, strlen(name), flags);
1002 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1004 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1005 of an SV instead of a string/length pair.
1011 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1015 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1016 namepv = SvPV(name, namelen);
1018 flags |= padadd_UTF8_NAME;
1019 return pad_findmy_pvn(namepv, namelen, flags);
1023 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1025 Find the position of the lexical C<$_> in the pad of the
1026 currently-executing function. Returns the offset in the current pad,
1027 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1028 the global one should be used instead).
1029 L</find_rundefsv> is likely to be more convenient.
1035 Perl_find_rundefsvoffset(pTHX)
1040 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1041 NULL, &out_sv, &out_flags);
1045 =for apidoc Am|SV *|find_rundefsv
1047 Find and return the variable that is named C<$_> in the lexical scope
1048 of the currently-executing function. This may be a lexical C<$_>,
1049 or will otherwise be the global one.
1055 Perl_find_rundefsv(pTHX)
1061 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1062 NULL, &namesv, &flags);
1064 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1071 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1077 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1079 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1080 NULL, &namesv, &flags);
1082 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1085 return AvARRAY(PADLIST_ARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1089 =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
1091 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1092 in the inner pads if it's found in an outer one.
1094 Returns the offset in the bottom pad of the lex or the fake lex.
1095 cv is the CV in which to start the search, and seq is the current cop_seq
1096 to match against. If warn is true, print appropriate warnings. The out_*
1097 vars return values, and so are pointers to where the returned values
1098 should be stored. out_capture, if non-null, requests that the innermost
1099 instance of the lexical is captured; out_name_sv is set to the innermost
1100 matched namesv or fake namesv; out_flags returns the flags normally
1101 associated with the IVX field of a fake namesv.
1103 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1104 then comes back down, adding fake entries as it goes. It has to be this way
1105 because fake namesvs in anon protoypes have to store in xlow the index into
1111 /* the CV has finished being compiled. This is not a sufficient test for
1112 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1113 #define CvCOMPILED(cv) CvROOT(cv)
1115 /* the CV does late binding of its lexicals */
1116 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1120 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1121 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1124 I32 offset, new_offset;
1127 const PADLIST * const padlist = CvPADLIST(cv);
1128 const bool staleok = !!(flags & padadd_STALEOK);
1130 PERL_ARGS_ASSERT_PAD_FINDLEX;
1132 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1133 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1135 flags &= ~ padadd_STALEOK; /* one-shot flag */
1139 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1140 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1141 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1142 out_capture ? " capturing" : "" ));
1144 /* first, search this pad */
1146 if (padlist) { /* not an undef CV */
1147 I32 fake_offset = 0;
1148 const AV * const nameav = PADLIST_ARRAY(padlist)[0];
1149 SV * const * const name_svp = AvARRAY(nameav);
1151 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1152 const SV * const namesv = name_svp[offset];
1153 if (namesv && namesv != &PL_sv_undef
1154 && SvCUR(namesv) == namelen
1155 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1156 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1158 if (SvFAKE(namesv)) {
1159 fake_offset = offset; /* in case we don't find a real one */
1162 /* is seq within the range _LOW to _HIGH ?
1163 * This is complicated by the fact that PL_cop_seqmax
1164 * may have wrapped around at some point */
1165 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1166 continue; /* not yet introduced */
1168 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1169 /* in compiling scope */
1171 (seq > COP_SEQ_RANGE_LOW(namesv))
1172 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1173 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1178 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1180 ( seq > COP_SEQ_RANGE_LOW(namesv)
1181 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1183 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1184 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1190 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1191 if (offset > 0) { /* not fake */
1193 *out_name_sv = name_svp[offset]; /* return the namesv */
1195 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1196 * instances. For now, we just test !CvUNIQUE(cv), but
1197 * ideally, we should detect my's declared within loops
1198 * etc - this would allow a wider range of 'not stayed
1199 * shared' warnings. We also treated already-compiled
1200 * lexes as not multi as viewed from evals. */
1202 *out_flags = CvANON(cv) ?
1204 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1205 ? PAD_FAKELEX_MULTI : 0;
1207 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1208 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1209 PTR2UV(cv), (long)offset,
1210 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1211 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1213 else { /* fake match */
1214 offset = fake_offset;
1215 *out_name_sv = name_svp[offset]; /* return the namesv */
1216 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1217 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1218 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1219 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1220 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1224 /* return the lex? */
1229 if (SvPAD_OUR(*out_name_sv)) {
1230 *out_capture = NULL;
1234 /* trying to capture from an anon prototype? */
1236 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1237 : *out_flags & PAD_FAKELEX_ANON)
1240 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1241 "Variable \"%"SVf"\" is not available",
1242 newSVpvn_flags(namepv, namelen,
1244 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1246 *out_capture = NULL;
1252 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1253 && !SvPAD_STATE(name_svp[offset])
1254 && warn && ckWARN(WARN_CLOSURE)) {
1256 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1257 "Variable \"%"SVf"\" will not stay shared",
1258 newSVpvn_flags(namepv, namelen,
1260 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1263 if (fake_offset && CvANON(cv)
1264 && CvCLONE(cv) &&!CvCLONED(cv))
1267 /* not yet caught - look further up */
1268 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1269 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1272 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1274 newwarn, out_capture, out_name_sv, out_flags);
1279 *out_capture = AvARRAY(PADLIST_ARRAY(padlist)[
1280 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1281 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1282 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1283 PTR2UV(cv), PTR2UV(*out_capture)));
1285 if (SvPADSTALE(*out_capture)
1286 && (!CvDEPTH(cv) || !staleok)
1287 && !SvPAD_STATE(name_svp[offset]))
1289 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1290 "Variable \"%"SVf"\" is not available",
1291 newSVpvn_flags(namepv, namelen,
1293 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1294 *out_capture = NULL;
1297 if (!*out_capture) {
1298 if (namelen != 0 && *namepv == '@')
1299 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1300 else if (namelen != 0 && *namepv == '%')
1301 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1303 *out_capture = sv_newmortal();
1311 /* it's not in this pad - try above */
1316 /* out_capture non-null means caller wants us to capture lex; in
1317 * addition we capture ourselves unless it's an ANON/format */
1318 new_capturep = out_capture ? out_capture :
1319 CvLATE(cv) ? NULL : &new_capture;
1321 offset = pad_findlex(namepv, namelen,
1322 flags | padadd_STALEOK*(new_capturep == &new_capture),
1323 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1324 new_capturep, out_name_sv, out_flags);
1325 if ((PADOFFSET)offset == NOT_IN_PAD)
1328 /* found in an outer CV. Add appropriate fake entry to this pad */
1330 /* don't add new fake entries (via eval) to CVs that we have already
1331 * finished compiling, or to undef CVs */
1332 if (CvCOMPILED(cv) || !padlist)
1333 return 0; /* this dummy (and invalid) value isnt used by the caller */
1336 /* This relies on sv_setsv_flags() upgrading the destination to the same
1337 type as the source, independent of the flags set, and on it being
1338 "good" and only copying flag bits and pointers that it understands.
1340 SV *new_namesv = newSVsv(*out_name_sv);
1341 AV * const ocomppad_name = PL_comppad_name;
1342 PAD * const ocomppad = PL_comppad;
1343 PL_comppad_name = PADLIST_ARRAY(padlist)[0];
1344 PL_comppad = PADLIST_ARRAY(padlist)[1];
1345 PL_curpad = AvARRAY(PL_comppad);
1348 = pad_alloc_name(new_namesv,
1349 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1350 SvPAD_TYPED(*out_name_sv)
1351 ? SvSTASH(*out_name_sv) : NULL,
1352 SvOURSTASH(*out_name_sv)
1355 SvFAKE_on(new_namesv);
1356 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1357 "Pad addname: %ld \"%.*s\" FAKE\n",
1359 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1360 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1362 PARENT_PAD_INDEX_set(new_namesv, 0);
1363 if (SvPAD_OUR(new_namesv)) {
1364 NOOP; /* do nothing */
1366 else if (CvLATE(cv)) {
1367 /* delayed creation - just note the offset within parent pad */
1368 PARENT_PAD_INDEX_set(new_namesv, offset);
1372 /* immediate creation - capture outer value right now */
1373 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1374 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1375 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1376 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1378 *out_name_sv = new_namesv;
1379 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1381 PL_comppad_name = ocomppad_name;
1382 PL_comppad = ocomppad;
1383 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1391 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1393 Get the value at offset I<po> in the current (compiling or executing) pad.
1394 Use macro PAD_SV instead of calling this function directly.
1400 Perl_pad_sv(pTHX_ PADOFFSET po)
1403 ASSERT_CURPAD_ACTIVE("pad_sv");
1406 Perl_croak(aTHX_ "panic: pad_sv po");
1407 DEBUG_X(PerlIO_printf(Perl_debug_log,
1408 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1409 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1411 return PL_curpad[po];
1415 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1417 Set the value at offset I<po> in the current (compiling or executing) pad.
1418 Use the macro PAD_SETSV() rather than calling this function directly.
1424 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1428 PERL_ARGS_ASSERT_PAD_SETSV;
1430 ASSERT_CURPAD_ACTIVE("pad_setsv");
1432 DEBUG_X(PerlIO_printf(Perl_debug_log,
1433 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1434 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1439 #endif /* DEBUGGING */
1442 =for apidoc m|void|pad_block_start|int full
1444 Update the pad compilation state variables on entry to a new block.
1449 /* XXX DAPM perhaps:
1450 * - integrate this in general state-saving routine ???
1451 * - combine with the state-saving going on in pad_new ???
1452 * - introduce a new SAVE type that does all this in one go ?
1456 Perl_pad_block_start(pTHX_ int full)
1459 ASSERT_CURPAD_ACTIVE("pad_block_start");
1460 SAVEI32(PL_comppad_name_floor);
1461 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1463 PL_comppad_name_fill = PL_comppad_name_floor;
1464 if (PL_comppad_name_floor < 0)
1465 PL_comppad_name_floor = 0;
1466 SAVEI32(PL_min_intro_pending);
1467 SAVEI32(PL_max_intro_pending);
1468 PL_min_intro_pending = 0;
1469 SAVEI32(PL_comppad_name_fill);
1470 SAVEI32(PL_padix_floor);
1471 PL_padix_floor = PL_padix;
1472 PL_pad_reset_pending = FALSE;
1476 =for apidoc m|U32|intro_my
1478 "Introduce" my variables to visible status. This is called during parsing
1479 at the end of each statement to make lexical variables visible to
1480 subsequent statements.
1493 ASSERT_CURPAD_ACTIVE("intro_my");
1494 if (! PL_min_intro_pending)
1495 return PL_cop_seqmax;
1497 svp = AvARRAY(PL_comppad_name);
1498 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1499 SV * const sv = svp[i];
1501 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1502 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1504 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1505 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1506 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1507 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1508 (long)i, SvPVX_const(sv),
1509 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1510 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1514 seq = PL_cop_seqmax;
1516 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1518 PL_min_intro_pending = 0;
1519 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1520 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1521 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1527 =for apidoc m|void|pad_leavemy
1529 Cleanup at end of scope during compilation: set the max seq number for
1530 lexicals in this scope and warn of any lexicals that never got introduced.
1536 Perl_pad_leavemy(pTHX)
1540 SV * const * const svp = AvARRAY(PL_comppad_name);
1542 PL_pad_reset_pending = FALSE;
1544 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1545 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1546 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1547 const SV * const sv = svp[off];
1548 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1549 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1550 "%"SVf" never introduced",
1554 /* "Deintroduce" my variables that are leaving with this scope. */
1555 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1556 const SV * const sv = svp[off];
1557 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1558 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1560 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1561 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1562 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1563 (long)off, SvPVX_const(sv),
1564 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1565 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1570 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1572 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1573 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1577 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1579 Abandon the tmp in the current pad at offset po and replace with a
1586 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1589 ASSERT_CURPAD_LEGAL("pad_swipe");
1592 if (AvARRAY(PL_comppad) != PL_curpad)
1593 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1594 AvARRAY(PL_comppad), PL_curpad);
1595 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1596 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1597 (long)po, (long)AvFILLp(PL_comppad));
1599 DEBUG_X(PerlIO_printf(Perl_debug_log,
1600 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1601 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1604 SvPADTMP_off(PL_curpad[po]);
1606 SvREFCNT_dec(PL_curpad[po]);
1609 /* if pad tmps aren't shared between ops, then there's no need to
1610 * create a new tmp when an existing op is freed */
1611 #ifdef USE_BROKEN_PAD_RESET
1612 PL_curpad[po] = newSV(0);
1613 SvPADTMP_on(PL_curpad[po]);
1615 PL_curpad[po] = &PL_sv_undef;
1617 if ((I32)po < PL_padix)
1622 =for apidoc m|void|pad_reset
1624 Mark all the current temporaries for reuse
1629 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1630 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1631 * on the stack by OPs that use them, there are several ways to get an alias
1632 * to a shared TARG. Such an alias will change randomly and unpredictably.
1633 * We avoid doing this until we can think of a Better Way.
1639 #ifdef USE_BROKEN_PAD_RESET
1640 if (AvARRAY(PL_comppad) != PL_curpad)
1641 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1642 AvARRAY(PL_comppad), PL_curpad);
1644 DEBUG_X(PerlIO_printf(Perl_debug_log,
1645 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1646 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1647 (long)PL_padix, (long)PL_padix_floor
1651 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1653 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1654 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1655 SvPADTMP_off(PL_curpad[po]);
1657 PL_padix = PL_padix_floor;
1660 PL_pad_reset_pending = FALSE;
1664 =for apidoc Amx|void|pad_tidy|padtidy_type type
1666 Tidy up a pad at the end of compilation of the code to which it belongs.
1667 Jobs performed here are: remove most stuff from the pads of anonsub
1668 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1669 the kind of subroutine:
1671 padtidy_SUB ordinary subroutine
1672 padtidy_SUBCLONE prototype for lexical closure
1673 padtidy_FORMAT format
1678 /* XXX DAPM surely most of this stuff should be done properly
1679 * at the right time beforehand, rather than going around afterwards
1680 * cleaning up our mistakes ???
1684 Perl_pad_tidy(pTHX_ padtidy_type type)
1688 ASSERT_CURPAD_ACTIVE("pad_tidy");
1690 /* If this CV has had any 'eval-capable' ops planted in it
1691 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1692 * anon prototypes in the chain of CVs should be marked as cloneable,
1693 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1694 * the right CvOUTSIDE.
1695 * If running with -d, *any* sub may potentially have an eval
1696 * executed within it.
1699 if (PL_cv_has_eval || PL_perldb) {
1701 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1702 if (cv != PL_compcv && CvCOMPILED(cv))
1703 break; /* no need to mark already-compiled code */
1705 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1706 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1713 /* extend curpad to match namepad */
1714 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1715 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1717 if (type == padtidy_SUBCLONE) {
1718 SV * const * const namep = AvARRAY(PL_comppad_name);
1721 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1724 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1727 * The only things that a clonable function needs in its
1728 * pad are anonymous subs.
1729 * The rest are created anew during cloning.
1731 if (!((namesv = namep[ix]) != NULL &&
1732 namesv != &PL_sv_undef &&
1733 *SvPVX_const(namesv) == '&'))
1735 SvREFCNT_dec(PL_curpad[ix]);
1736 PL_curpad[ix] = NULL;
1740 else if (type == padtidy_SUB) {
1741 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1742 AV * const av = newAV(); /* Will be @_ */
1743 av_store(PL_comppad, 0, MUTABLE_SV(av));
1747 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1748 SV * const * const namep = AvARRAY(PL_comppad_name);
1750 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1751 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1753 if (!SvPADMY(PL_curpad[ix])) {
1754 SvPADTMP_on(PL_curpad[ix]);
1755 } else if (!SvFAKE(namep[ix])) {
1756 /* This is a work around for how the current implementation of
1757 ?{ } blocks in regexps interacts with lexicals.
1759 One of our lexicals.
1760 Can't do this on all lexicals, otherwise sub baz() won't
1769 because completion of compiling &bar calling pad_tidy()
1770 would cause (top level) $foo to be marked as stale, and
1771 "no longer available". */
1772 SvPADSTALE_on(PL_curpad[ix]);
1776 PL_curpad = AvARRAY(PL_comppad);
1780 =for apidoc m|void|pad_free|PADOFFSET po
1782 Free the SV at offset po in the current pad.
1787 /* XXX DAPM integrate with pad_swipe ???? */
1789 Perl_pad_free(pTHX_ PADOFFSET po)
1792 ASSERT_CURPAD_LEGAL("pad_free");
1795 if (AvARRAY(PL_comppad) != PL_curpad)
1796 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1797 AvARRAY(PL_comppad), PL_curpad);
1799 Perl_croak(aTHX_ "panic: pad_free po");
1801 DEBUG_X(PerlIO_printf(Perl_debug_log,
1802 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1803 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1806 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1807 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1809 if ((I32)po < PL_padix)
1814 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1816 Dump the contents of a padlist
1822 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1831 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1836 pad_name = *PADLIST_ARRAY(padlist);
1837 pad = PADLIST_ARRAY(padlist)[1];
1838 pname = AvARRAY(pad_name);
1839 ppad = AvARRAY(pad);
1840 Perl_dump_indent(aTHX_ level, file,
1841 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1842 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1845 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1846 const SV *namesv = pname[ix];
1847 if (namesv && namesv == &PL_sv_undef) {
1852 Perl_dump_indent(aTHX_ level+1, file,
1853 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1856 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1857 SvPVX_const(namesv),
1858 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1859 (unsigned long)PARENT_PAD_INDEX(namesv)
1863 Perl_dump_indent(aTHX_ level+1, file,
1864 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1867 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1868 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1869 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1874 Perl_dump_indent(aTHX_ level+1, file,
1875 "%2d. 0x%"UVxf"<%lu>\n",
1878 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1887 =for apidoc m|void|cv_dump|CV *cv|const char *title
1889 dump the contents of a CV
1895 S_cv_dump(pTHX_ const CV *cv, const char *title)
1898 const CV * const outside = CvOUTSIDE(cv);
1899 PADLIST* const padlist = CvPADLIST(cv);
1901 PERL_ARGS_ASSERT_CV_DUMP;
1903 PerlIO_printf(Perl_debug_log,
1904 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1907 (CvANON(cv) ? "ANON"
1908 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1909 : (cv == PL_main_cv) ? "MAIN"
1910 : CvUNIQUE(cv) ? "UNIQUE"
1911 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1914 : CvANON(outside) ? "ANON"
1915 : (outside == PL_main_cv) ? "MAIN"
1916 : CvUNIQUE(outside) ? "UNIQUE"
1917 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1919 PerlIO_printf(Perl_debug_log,
1920 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1921 do_dump_pad(1, Perl_debug_log, padlist, 1);
1924 #endif /* DEBUGGING */
1927 =for apidoc Am|CV *|cv_clone|CV *proto
1929 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1930 of the function: its code, pad structure, and other attributes.
1931 The prototype is combined with a capture of outer lexicals to which the
1932 code refers, which are taken from the currently-executing instance of
1933 the immediately surrounding code.
1939 Perl_cv_clone(pTHX_ CV *proto)
1943 PADLIST* const protopadlist = CvPADLIST(proto);
1944 const PAD *const protopad_name = *PADLIST_ARRAY(protopadlist);
1945 const PAD *const protopad = PADLIST_ARRAY(protopadlist)[1];
1946 SV** const pname = AvARRAY(protopad_name);
1947 SV** const ppad = AvARRAY(protopad);
1948 const I32 fname = AvFILLp(protopad_name);
1949 const I32 fpad = AvFILLp(protopad);
1955 PERL_ARGS_ASSERT_CV_CLONE;
1957 assert(!CvUNIQUE(proto));
1959 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1960 * reliable. The currently-running sub is always the one we need to
1962 * Note that in general for formats, CvOUTSIDE != find_runcv.
1963 * Since formats may be nested inside closures, CvOUTSIDE may point
1964 * to a prototype; we instead want the cloned parent who called us.
1967 if (SvTYPE(proto) == SVt_PVCV)
1968 outside = find_runcv(NULL);
1970 outside = CvOUTSIDE(proto);
1971 if ((CvCLONE(outside) && ! CvCLONED(outside))
1972 || !CvPADLIST(outside)
1973 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1974 outside = find_runcv_where(
1975 FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
1977 /* outside could be null */
1980 depth = outside ? CvDEPTH(outside) : 0;
1981 assert(depth || SvTYPE(proto) == SVt_PVFM);
1984 assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
1987 SAVESPTR(PL_compcv);
1989 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1990 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1994 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1996 CvGV_set(cv,CvGV(proto));
1997 CvSTASH_set(cv, CvSTASH(proto));
1999 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2001 CvSTART(cv) = CvSTART(proto);
2003 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2004 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2007 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2009 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2011 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2012 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2014 av_fill(PL_comppad, fpad);
2015 for (ix = fname; ix > 0; ix--)
2016 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
2018 PL_curpad = AvARRAY(PL_comppad);
2020 outpad = outside && CvPADLIST(outside)
2021 ? AvARRAY(PADLIST_ARRAY(CvPADLIST(outside))[depth])
2023 assert(outpad || SvTYPE(cv) == SVt_PVFM);
2024 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2026 for (ix = fpad; ix > 0; ix--) {
2027 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2029 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2030 if (SvFAKE(namesv)) { /* lexical from outside? */
2031 /* formats may have an inactive, or even undefined, parent;
2032 but state vars are always available. */
2033 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2034 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2035 && (!outside || !CvDEPTH(outside))) ) {
2036 assert(SvTYPE(cv) == SVt_PVFM);
2037 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2038 "Variable \"%"SVf"\" is not available", namesv);
2042 SvREFCNT_inc_simple_void_NN(sv);
2045 const char sigil = SvPVX_const(namesv)[0];
2047 sv = SvREFCNT_inc(ppad[ix]);
2048 else if (sigil == '@')
2049 sv = MUTABLE_SV(newAV());
2050 else if (sigil == '%')
2051 sv = MUTABLE_SV(newHV());
2055 /* reset the 'assign only once' flag on each state var */
2056 if (SvPAD_STATE(namesv))
2060 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2061 sv = SvREFCNT_inc_NN(ppad[ix]);
2071 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2072 if (outside) cv_dump(outside, "Outside");
2073 cv_dump(proto, "Proto");
2080 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2081 * The prototype was marked as a candiate for const-ization,
2082 * so try to grab the current const value, and if successful,
2083 * turn into a const sub:
2085 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2088 /* For this calling case, op_const_sv returns a *copy*, which we
2089 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2090 Need to fix how lib/constant.pm works to eliminate this. */
2091 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2102 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2104 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2105 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2106 moved to a pre-existing CV struct.
2112 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2116 AV * const comppad_name = PADLIST_ARRAY(padlist)[0];
2117 AV * const comppad = PADLIST_ARRAY(padlist)[1];
2118 SV ** const namepad = AvARRAY(comppad_name);
2119 SV ** const curpad = AvARRAY(comppad);
2121 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2122 PERL_UNUSED_ARG(old_cv);
2124 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2125 const SV * const namesv = namepad[ix];
2126 if (namesv && namesv != &PL_sv_undef
2127 && *SvPVX_const(namesv) == '&')
2129 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2130 CV * const innercv = MUTABLE_CV(curpad[ix]);
2131 assert(CvWEAKOUTSIDE(innercv));
2132 assert(CvOUTSIDE(innercv) == old_cv);
2133 CvOUTSIDE(innercv) = new_cv;
2135 else { /* format reference */
2136 SV * const rv = curpad[ix];
2138 if (!SvOK(rv)) continue;
2140 assert(SvWEAKREF(rv));
2141 innercv = (CV *)SvRV(rv);
2142 assert(!CvWEAKOUTSIDE(innercv));
2143 SvREFCNT_dec(CvOUTSIDE(innercv));
2144 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2151 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2153 Push a new pad frame onto the padlist, unless there's already a pad at
2154 this depth, in which case don't bother creating a new one. Then give
2155 the new pad an @_ in slot zero.
2161 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2165 PERL_ARGS_ASSERT_PAD_PUSH;
2167 if (depth > PADLIST_MAX(padlist) || !PADLIST_ARRAY(padlist)[depth]) {
2168 PAD** const svp = PADLIST_ARRAY(padlist);
2169 AV* const newpad = newAV();
2170 SV** const oldpad = AvARRAY(svp[depth-1]);
2171 I32 ix = AvFILLp((const AV *)svp[1]);
2172 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2173 SV** const names = AvARRAY(svp[0]);
2176 for ( ;ix > 0; ix--) {
2177 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2178 const char sigil = SvPVX_const(names[ix])[0];
2179 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2180 || (SvFLAGS(names[ix]) & SVpad_STATE)
2183 /* outer lexical or anon code */
2184 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2186 else { /* our own lexical */
2189 sv = MUTABLE_SV(newAV());
2190 else if (sigil == '%')
2191 sv = MUTABLE_SV(newHV());
2194 av_store(newpad, ix, sv);
2198 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2199 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2202 /* save temporaries on recursion? */
2203 SV * const sv = newSV(0);
2204 av_store(newpad, ix, sv);
2209 av_store(newpad, 0, MUTABLE_SV(av));
2212 padlist_store(padlist, depth, newpad);
2217 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2219 Looks up the type of the lexical variable at position I<po> in the
2220 currently-compiling pad. If the variable is typed, the stash of the
2221 class to which it is typed is returned. If not, C<NULL> is returned.
2227 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2230 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2231 if ( SvPAD_TYPED(*av) ) {
2232 return SvSTASH(*av);
2237 #if defined(USE_ITHREADS)
2239 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2242 =for apidoc padlist_dup
2250 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2256 PERL_ARGS_ASSERT_PADLIST_DUP;
2261 cloneall = param->flags & CLONEf_COPY_STACKS
2262 || SvREFCNT(PADLIST_ARRAY(srcpad)[1]) > 1;
2263 assert (SvREFCNT(PADLIST_ARRAY(srcpad)[1]) == 1);
2265 max = cloneall ? PADLIST_MAX(srcpad) : 1;
2267 Newx(dstpad, 1, PADLIST);
2268 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2269 PADLIST_MAX(dstpad) = max;
2270 Newx(PADLIST_ARRAY(dstpad), max + 1, PAD *);
2274 for (depth = 0; depth <= max; ++depth)
2275 PADLIST_ARRAY(dstpad)[depth] =
2276 av_dup_inc(PADLIST_ARRAY(srcpad)[depth], param);
2278 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2279 to build anything other than the first level of pads. */
2280 I32 ix = AvFILLp(PADLIST_ARRAY(srcpad)[1]);
2282 const I32 names_fill = AvFILLp(PADLIST_ARRAY(srcpad)[0]);
2283 const PAD *const srcpad1 = PADLIST_ARRAY(srcpad)[1];
2284 SV **oldpad = AvARRAY(srcpad1);
2289 PADLIST_ARRAY(dstpad)[0] =
2290 av_dup_inc(PADLIST_ARRAY(srcpad)[0], param);
2291 names = AvARRAY(PADLIST_ARRAY(dstpad)[0]);
2295 av_extend(pad1, ix);
2296 PADLIST_ARRAY(dstpad)[1] = pad1;
2297 pad1a = AvARRAY(pad1);
2302 for ( ;ix > 0; ix--) {
2305 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2306 const char sigil = SvPVX_const(names[ix])[0];
2307 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2308 || (SvFLAGS(names[ix]) & SVpad_STATE)
2311 /* outer lexical or anon code */
2312 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2314 else { /* our own lexical */
2315 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2316 /* This is a work around for how the current
2317 implementation of ?{ } blocks in regexps
2318 interacts with lexicals. */
2319 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2324 sv = MUTABLE_SV(newAV());
2325 else if (sigil == '%')
2326 sv = MUTABLE_SV(newHV());
2334 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2335 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2338 /* save temporaries on recursion? */
2339 SV * const sv = newSV(0);
2342 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2343 FIXTHAT before merging this branch.
2344 (And I know how to) */
2345 if (SvPADMY(oldpad[ix]))
2353 args = newAV(); /* Will be @_ */
2355 pad1a[0] = (SV *)args;
2363 #endif /* USE_ITHREADS */
2366 Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
2370 SSize_t const oldmax = PADLIST_MAX(padlist);
2372 PERL_ARGS_ASSERT_PADLIST_STORE;
2376 if (key > PADLIST_MAX(padlist)) {
2377 av_extend_guts(NULL,key,&PADLIST_MAX(padlist),
2378 (SV ***)&PADLIST_ARRAY(padlist),
2379 (SV ***)&PADLIST_ARRAY(padlist));
2380 Zero(PADLIST_ARRAY(padlist)+oldmax+1, PADLIST_MAX(padlist)-oldmax,
2383 ary = PADLIST_ARRAY(padlist);
2384 SvREFCNT_dec(ary[key]);
2391 * c-indentation-style: bsd
2393 * indent-tabs-mode: nil
2396 * ex: set ts=8 sts=4 sw=4 et: