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 */
378 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
381 /* This statement and the subsequence if block was pad_undef(). */
382 pad_peg("pad_undef");
384 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
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 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
409 SV ** const namepad = AvARRAY(comppad_name);
410 AV * const comppad = MUTABLE_AV(AvARRAY(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 = AvFILLp(padlist);
450 SV* const sv = AvARRAY(padlist)[ix--];
452 if (sv == (const SV *)PL_comppad) {
460 SV *const sv = AvARRAY(padlist)[0];
461 if (sv == (const SV *)PL_comppad_name)
462 PL_comppad_name = NULL;
465 AvREAL_off(CvPADLIST(cv));
466 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
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 I<optype> should be an opcode indicating the type of operation that the
788 pad entry is to support. This doesn't affect operational semantics,
789 but is used for debugging.
795 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
799 SV* const name = newSV_type(SVt_PVNV);
801 PERL_ARGS_ASSERT_PAD_ADD_ANON;
804 sv_setpvs(name, "&");
805 /* These two aren't used; just make sure they're not equal to
806 * PERL_PADSEQ_INTRO */
807 COP_SEQ_RANGE_LOW_set(name, 0);
808 COP_SEQ_RANGE_HIGH_set(name, 0);
809 ix = pad_alloc(optype, SVs_PADMY);
810 av_store(PL_comppad_name, ix, name);
811 /* XXX DAPM use PL_curpad[] ? */
812 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
813 av_store(PL_comppad, ix, (SV*)func);
815 SV *rv = newRV_inc((SV *)func);
817 assert (SvTYPE(func) == SVt_PVFM);
818 av_store(PL_comppad, ix, rv);
820 SvPADMY_on((SV*)func);
822 /* to avoid ref loops, we never have parent + child referencing each
823 * other simultaneously */
824 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
825 assert(!CvWEAKOUTSIDE(func));
826 CvWEAKOUTSIDE_on(func);
827 SvREFCNT_dec(CvOUTSIDE(func));
833 =for apidoc pad_check_dup
835 Check for duplicate declarations: report any of:
837 * a my in the current scope with the same name;
838 * an our (anywhere in the pad) with the same name and the
839 same stash as C<ourstash>
841 C<is_our> indicates that the name to check is an 'our' declaration.
847 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
852 const U32 is_our = flags & padadd_OUR;
854 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
856 ASSERT_CURPAD_ACTIVE("pad_check_dup");
858 assert((flags & ~padadd_OUR) == 0);
860 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
861 return; /* nothing to check */
863 svp = AvARRAY(PL_comppad_name);
864 top = AvFILLp(PL_comppad_name);
865 /* check the current scope */
866 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
868 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
869 SV * const sv = svp[off];
871 && sv != &PL_sv_undef
873 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
874 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
877 if (is_our && (SvPAD_OUR(sv)))
878 break; /* "our" masking "our" */
879 Perl_warner(aTHX_ packWARN(WARN_MISC),
880 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
881 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
883 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
884 ? "scope" : "statement"));
889 /* check the rest of the pad */
892 SV * const sv = svp[off];
894 && sv != &PL_sv_undef
896 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
897 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
898 && SvOURSTASH(sv) == ourstash
901 Perl_warner(aTHX_ packWARN(WARN_MISC),
902 "\"our\" variable %"SVf" redeclared", sv);
903 if ((I32)off <= PL_comppad_name_floor)
904 Perl_warner(aTHX_ packWARN(WARN_MISC),
905 "\t(Did you mean \"local\" instead of \"our\"?)\n");
915 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
917 Given the name of a lexical variable, find its position in the
918 currently-compiling pad.
919 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
920 I<flags> is reserved and must be zero.
921 If it is not in the current pad but appears in the pad of any lexically
922 enclosing scope, then a pseudo-entry for it is added in the current pad.
923 Returns the offset in the current pad,
924 or C<NOT_IN_PAD> if no such lexical is in scope.
930 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
939 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
941 pad_peg("pad_findmy_pvn");
943 if (flags & ~padadd_UTF8_NAME)
944 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
947 if (flags & padadd_UTF8_NAME) {
949 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
952 flags |= padadd_UTF8_NAME;
954 flags &= ~padadd_UTF8_NAME;
957 offset = pad_findlex(namepv, namelen, flags,
958 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
959 if ((PADOFFSET)offset != NOT_IN_PAD)
962 /* look for an our that's being introduced; this allows
963 * our $foo = 0 unless defined $foo;
964 * to not give a warning. (Yes, this is a hack) */
966 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
967 name_svp = AvARRAY(nameav);
968 for (offset = AvFILLp(nameav); offset > 0; offset--) {
969 const SV * const namesv = name_svp[offset];
970 if (namesv && namesv != &PL_sv_undef
972 && (SvPAD_OUR(namesv))
973 && SvCUR(namesv) == namelen
974 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
975 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
976 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
984 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
986 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
987 instead of a string/length pair.
993 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
995 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
996 return pad_findmy_pvn(name, strlen(name), flags);
1000 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1002 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1003 of an SV instead of a string/length pair.
1009 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1013 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1014 namepv = SvPV(name, namelen);
1016 flags |= padadd_UTF8_NAME;
1017 return pad_findmy_pvn(namepv, namelen, flags);
1021 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1023 Find the position of the lexical C<$_> in the pad of the
1024 currently-executing function. Returns the offset in the current pad,
1025 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1026 the global one should be used instead).
1027 L</find_rundefsv> is likely to be more convenient.
1033 Perl_find_rundefsvoffset(pTHX)
1038 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1039 NULL, &out_sv, &out_flags);
1043 =for apidoc Am|SV *|find_rundefsv
1045 Find and return the variable that is named C<$_> in the lexical scope
1046 of the currently-executing function. This may be a lexical C<$_>,
1047 or will otherwise be the global one.
1053 Perl_find_rundefsv(pTHX)
1059 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1060 NULL, &namesv, &flags);
1062 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1069 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1075 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1077 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1078 NULL, &namesv, &flags);
1080 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1083 return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1087 =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
1089 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1090 in the inner pads if it's found in an outer one.
1092 Returns the offset in the bottom pad of the lex or the fake lex.
1093 cv is the CV in which to start the search, and seq is the current cop_seq
1094 to match against. If warn is true, print appropriate warnings. The out_*
1095 vars return values, and so are pointers to where the returned values
1096 should be stored. out_capture, if non-null, requests that the innermost
1097 instance of the lexical is captured; out_name_sv is set to the innermost
1098 matched namesv or fake namesv; out_flags returns the flags normally
1099 associated with the IVX field of a fake namesv.
1101 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1102 then comes back down, adding fake entries as it goes. It has to be this way
1103 because fake namesvs in anon protoypes have to store in xlow the index into
1109 /* the CV has finished being compiled. This is not a sufficient test for
1110 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1111 #define CvCOMPILED(cv) CvROOT(cv)
1113 /* the CV does late binding of its lexicals */
1114 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1118 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1119 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1122 I32 offset, new_offset;
1125 const AV * const padlist = CvPADLIST(cv);
1126 const bool staleok = !!(flags & padadd_STALEOK);
1128 PERL_ARGS_ASSERT_PAD_FINDLEX;
1130 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1131 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1133 flags &= ~ padadd_STALEOK; /* one-shot flag */
1137 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1138 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1139 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1140 out_capture ? " capturing" : "" ));
1142 /* first, search this pad */
1144 if (padlist) { /* not an undef CV */
1145 I32 fake_offset = 0;
1146 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1147 SV * const * const name_svp = AvARRAY(nameav);
1149 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1150 const SV * const namesv = name_svp[offset];
1151 if (namesv && namesv != &PL_sv_undef
1152 && SvCUR(namesv) == namelen
1153 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1154 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1156 if (SvFAKE(namesv)) {
1157 fake_offset = offset; /* in case we don't find a real one */
1160 /* is seq within the range _LOW to _HIGH ?
1161 * This is complicated by the fact that PL_cop_seqmax
1162 * may have wrapped around at some point */
1163 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1164 continue; /* not yet introduced */
1166 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1167 /* in compiling scope */
1169 (seq > COP_SEQ_RANGE_LOW(namesv))
1170 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1171 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1176 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1178 ( seq > COP_SEQ_RANGE_LOW(namesv)
1179 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1181 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1182 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1188 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1189 if (offset > 0) { /* not fake */
1191 *out_name_sv = name_svp[offset]; /* return the namesv */
1193 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1194 * instances. For now, we just test !CvUNIQUE(cv), but
1195 * ideally, we should detect my's declared within loops
1196 * etc - this would allow a wider range of 'not stayed
1197 * shared' warnings. We also treated already-compiled
1198 * lexes as not multi as viewed from evals. */
1200 *out_flags = CvANON(cv) ?
1202 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1203 ? PAD_FAKELEX_MULTI : 0;
1205 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1206 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1207 PTR2UV(cv), (long)offset,
1208 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1209 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1211 else { /* fake match */
1212 offset = fake_offset;
1213 *out_name_sv = name_svp[offset]; /* return the namesv */
1214 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1215 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1216 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1217 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1218 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1222 /* return the lex? */
1227 if (SvPAD_OUR(*out_name_sv)) {
1228 *out_capture = NULL;
1232 /* trying to capture from an anon prototype? */
1234 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1235 : *out_flags & PAD_FAKELEX_ANON)
1238 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1239 "Variable \"%"SVf"\" is not available",
1240 newSVpvn_flags(namepv, namelen,
1242 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1244 *out_capture = NULL;
1250 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1251 && !SvPAD_STATE(name_svp[offset])
1252 && warn && ckWARN(WARN_CLOSURE)) {
1254 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1255 "Variable \"%"SVf"\" will not stay shared",
1256 newSVpvn_flags(namepv, namelen,
1258 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1261 if (fake_offset && CvANON(cv)
1262 && CvCLONE(cv) &&!CvCLONED(cv))
1265 /* not yet caught - look further up */
1266 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1267 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1270 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1272 newwarn, out_capture, out_name_sv, out_flags);
1277 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1278 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1279 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1280 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1281 PTR2UV(cv), PTR2UV(*out_capture)));
1283 if (SvPADSTALE(*out_capture)
1284 && (!CvDEPTH(cv) || !staleok)
1285 && !SvPAD_STATE(name_svp[offset]))
1287 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1288 "Variable \"%"SVf"\" is not available",
1289 newSVpvn_flags(namepv, namelen,
1291 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1292 *out_capture = NULL;
1295 if (!*out_capture) {
1296 if (namelen != 0 && *namepv == '@')
1297 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1298 else if (namelen != 0 && *namepv == '%')
1299 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1301 *out_capture = sv_newmortal();
1309 /* it's not in this pad - try above */
1314 /* out_capture non-null means caller wants us to capture lex; in
1315 * addition we capture ourselves unless it's an ANON/format */
1316 new_capturep = out_capture ? out_capture :
1317 CvLATE(cv) ? NULL : &new_capture;
1319 offset = pad_findlex(namepv, namelen,
1320 flags | padadd_STALEOK*(new_capturep == &new_capture),
1321 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1322 new_capturep, out_name_sv, out_flags);
1323 if ((PADOFFSET)offset == NOT_IN_PAD)
1326 /* found in an outer CV. Add appropriate fake entry to this pad */
1328 /* don't add new fake entries (via eval) to CVs that we have already
1329 * finished compiling, or to undef CVs */
1330 if (CvCOMPILED(cv) || !padlist)
1331 return 0; /* this dummy (and invalid) value isnt used by the caller */
1334 /* This relies on sv_setsv_flags() upgrading the destination to the same
1335 type as the source, independent of the flags set, and on it being
1336 "good" and only copying flag bits and pointers that it understands.
1338 SV *new_namesv = newSVsv(*out_name_sv);
1339 AV * const ocomppad_name = PL_comppad_name;
1340 PAD * const ocomppad = PL_comppad;
1341 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1342 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1343 PL_curpad = AvARRAY(PL_comppad);
1346 = pad_alloc_name(new_namesv,
1347 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1348 SvPAD_TYPED(*out_name_sv)
1349 ? SvSTASH(*out_name_sv) : NULL,
1350 SvOURSTASH(*out_name_sv)
1353 SvFAKE_on(new_namesv);
1354 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1355 "Pad addname: %ld \"%.*s\" FAKE\n",
1357 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1358 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1360 PARENT_PAD_INDEX_set(new_namesv, 0);
1361 if (SvPAD_OUR(new_namesv)) {
1362 NOOP; /* do nothing */
1364 else if (CvLATE(cv)) {
1365 /* delayed creation - just note the offset within parent pad */
1366 PARENT_PAD_INDEX_set(new_namesv, offset);
1370 /* immediate creation - capture outer value right now */
1371 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1372 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1373 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1374 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1376 *out_name_sv = new_namesv;
1377 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1379 PL_comppad_name = ocomppad_name;
1380 PL_comppad = ocomppad;
1381 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1389 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1391 Get the value at offset I<po> in the current (compiling or executing) pad.
1392 Use macro PAD_SV instead of calling this function directly.
1398 Perl_pad_sv(pTHX_ PADOFFSET po)
1401 ASSERT_CURPAD_ACTIVE("pad_sv");
1404 Perl_croak(aTHX_ "panic: pad_sv po");
1405 DEBUG_X(PerlIO_printf(Perl_debug_log,
1406 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1407 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1409 return PL_curpad[po];
1413 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1415 Set the value at offset I<po> in the current (compiling or executing) pad.
1416 Use the macro PAD_SETSV() rather than calling this function directly.
1422 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1426 PERL_ARGS_ASSERT_PAD_SETSV;
1428 ASSERT_CURPAD_ACTIVE("pad_setsv");
1430 DEBUG_X(PerlIO_printf(Perl_debug_log,
1431 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1432 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1437 #endif /* DEBUGGING */
1440 =for apidoc m|void|pad_block_start|int full
1442 Update the pad compilation state variables on entry to a new block.
1447 /* XXX DAPM perhaps:
1448 * - integrate this in general state-saving routine ???
1449 * - combine with the state-saving going on in pad_new ???
1450 * - introduce a new SAVE type that does all this in one go ?
1454 Perl_pad_block_start(pTHX_ int full)
1457 ASSERT_CURPAD_ACTIVE("pad_block_start");
1458 SAVEI32(PL_comppad_name_floor);
1459 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1461 PL_comppad_name_fill = PL_comppad_name_floor;
1462 if (PL_comppad_name_floor < 0)
1463 PL_comppad_name_floor = 0;
1464 SAVEI32(PL_min_intro_pending);
1465 SAVEI32(PL_max_intro_pending);
1466 PL_min_intro_pending = 0;
1467 SAVEI32(PL_comppad_name_fill);
1468 SAVEI32(PL_padix_floor);
1469 PL_padix_floor = PL_padix;
1470 PL_pad_reset_pending = FALSE;
1474 =for apidoc m|U32|intro_my
1476 "Introduce" my variables to visible status. This is called during parsing
1477 at the end of each statement to make lexical variables visible to
1478 subsequent statements.
1491 ASSERT_CURPAD_ACTIVE("intro_my");
1492 if (! PL_min_intro_pending)
1493 return PL_cop_seqmax;
1495 svp = AvARRAY(PL_comppad_name);
1496 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1497 SV * const sv = svp[i];
1499 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1500 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1502 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1503 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1504 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1505 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1506 (long)i, SvPVX_const(sv),
1507 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1508 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1512 seq = PL_cop_seqmax;
1514 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1516 PL_min_intro_pending = 0;
1517 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1518 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1519 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1525 =for apidoc m|void|pad_leavemy
1527 Cleanup at end of scope during compilation: set the max seq number for
1528 lexicals in this scope and warn of any lexicals that never got introduced.
1534 Perl_pad_leavemy(pTHX)
1538 SV * const * const svp = AvARRAY(PL_comppad_name);
1540 PL_pad_reset_pending = FALSE;
1542 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1543 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1544 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1545 const SV * const sv = svp[off];
1546 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1547 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1548 "%"SVf" never introduced",
1552 /* "Deintroduce" my variables that are leaving with this scope. */
1553 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1554 const SV * const sv = svp[off];
1555 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1556 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1558 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1559 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1560 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1561 (long)off, SvPVX_const(sv),
1562 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1563 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1568 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1570 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1571 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1575 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1577 Abandon the tmp in the current pad at offset po and replace with a
1584 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1587 ASSERT_CURPAD_LEGAL("pad_swipe");
1590 if (AvARRAY(PL_comppad) != PL_curpad)
1591 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1592 AvARRAY(PL_comppad), PL_curpad);
1593 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1594 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1595 (long)po, (long)AvFILLp(PL_comppad));
1597 DEBUG_X(PerlIO_printf(Perl_debug_log,
1598 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1599 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1602 SvPADTMP_off(PL_curpad[po]);
1604 SvREFCNT_dec(PL_curpad[po]);
1607 /* if pad tmps aren't shared between ops, then there's no need to
1608 * create a new tmp when an existing op is freed */
1609 #ifdef USE_BROKEN_PAD_RESET
1610 PL_curpad[po] = newSV(0);
1611 SvPADTMP_on(PL_curpad[po]);
1613 PL_curpad[po] = &PL_sv_undef;
1615 if ((I32)po < PL_padix)
1620 =for apidoc m|void|pad_reset
1622 Mark all the current temporaries for reuse
1627 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1628 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1629 * on the stack by OPs that use them, there are several ways to get an alias
1630 * to a shared TARG. Such an alias will change randomly and unpredictably.
1631 * We avoid doing this until we can think of a Better Way.
1637 #ifdef USE_BROKEN_PAD_RESET
1638 if (AvARRAY(PL_comppad) != PL_curpad)
1639 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1640 AvARRAY(PL_comppad), PL_curpad);
1642 DEBUG_X(PerlIO_printf(Perl_debug_log,
1643 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1644 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1645 (long)PL_padix, (long)PL_padix_floor
1649 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1651 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1652 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1653 SvPADTMP_off(PL_curpad[po]);
1655 PL_padix = PL_padix_floor;
1658 PL_pad_reset_pending = FALSE;
1662 =for apidoc Amx|void|pad_tidy|padtidy_type type
1664 Tidy up a pad at the end of compilation of the code to which it belongs.
1665 Jobs performed here are: remove most stuff from the pads of anonsub
1666 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1667 the kind of subroutine:
1669 padtidy_SUB ordinary subroutine
1670 padtidy_SUBCLONE prototype for lexical closure
1671 padtidy_FORMAT format
1676 /* XXX DAPM surely most of this stuff should be done properly
1677 * at the right time beforehand, rather than going around afterwards
1678 * cleaning up our mistakes ???
1682 Perl_pad_tidy(pTHX_ padtidy_type type)
1686 ASSERT_CURPAD_ACTIVE("pad_tidy");
1688 /* If this CV has had any 'eval-capable' ops planted in it
1689 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1690 * anon prototypes in the chain of CVs should be marked as cloneable,
1691 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1692 * the right CvOUTSIDE.
1693 * If running with -d, *any* sub may potentially have an eval
1694 * executed within it.
1697 if (PL_cv_has_eval || PL_perldb) {
1699 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1700 if (cv != PL_compcv && CvCOMPILED(cv))
1701 break; /* no need to mark already-compiled code */
1703 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1704 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1711 /* extend curpad to match namepad */
1712 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1713 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1715 if (type == padtidy_SUBCLONE) {
1716 SV * const * const namep = AvARRAY(PL_comppad_name);
1719 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1722 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1725 * The only things that a clonable function needs in its
1726 * pad are anonymous subs.
1727 * The rest are created anew during cloning.
1729 if (!((namesv = namep[ix]) != NULL &&
1730 namesv != &PL_sv_undef &&
1731 *SvPVX_const(namesv) == '&'))
1733 SvREFCNT_dec(PL_curpad[ix]);
1734 PL_curpad[ix] = NULL;
1738 else if (type == padtidy_SUB) {
1739 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1740 AV * const av = newAV(); /* Will be @_ */
1741 av_store(PL_comppad, 0, MUTABLE_SV(av));
1745 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1746 SV * const * const namep = AvARRAY(PL_comppad_name);
1748 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1749 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1751 if (!SvPADMY(PL_curpad[ix])) {
1752 SvPADTMP_on(PL_curpad[ix]);
1753 } else if (!SvFAKE(namep[ix])) {
1754 /* This is a work around for how the current implementation of
1755 ?{ } blocks in regexps interacts with lexicals.
1757 One of our lexicals.
1758 Can't do this on all lexicals, otherwise sub baz() won't
1767 because completion of compiling &bar calling pad_tidy()
1768 would cause (top level) $foo to be marked as stale, and
1769 "no longer available". */
1770 SvPADSTALE_on(PL_curpad[ix]);
1774 PL_curpad = AvARRAY(PL_comppad);
1778 =for apidoc m|void|pad_free|PADOFFSET po
1780 Free the SV at offset po in the current pad.
1785 /* XXX DAPM integrate with pad_swipe ???? */
1787 Perl_pad_free(pTHX_ PADOFFSET po)
1790 ASSERT_CURPAD_LEGAL("pad_free");
1793 if (AvARRAY(PL_comppad) != PL_curpad)
1794 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1795 AvARRAY(PL_comppad), PL_curpad);
1797 Perl_croak(aTHX_ "panic: pad_free po");
1799 DEBUG_X(PerlIO_printf(Perl_debug_log,
1800 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1801 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1804 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1805 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1807 if ((I32)po < PL_padix)
1812 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1814 Dump the contents of a padlist
1820 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1829 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1834 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1835 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1836 pname = AvARRAY(pad_name);
1837 ppad = AvARRAY(pad);
1838 Perl_dump_indent(aTHX_ level, file,
1839 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1840 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1843 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1844 const SV *namesv = pname[ix];
1845 if (namesv && namesv == &PL_sv_undef) {
1850 Perl_dump_indent(aTHX_ level+1, file,
1851 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1854 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1855 SvPVX_const(namesv),
1856 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1857 (unsigned long)PARENT_PAD_INDEX(namesv)
1861 Perl_dump_indent(aTHX_ level+1, file,
1862 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1865 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1866 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1867 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1872 Perl_dump_indent(aTHX_ level+1, file,
1873 "%2d. 0x%"UVxf"<%lu>\n",
1876 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1885 =for apidoc m|void|cv_dump|CV *cv|const char *title
1887 dump the contents of a CV
1893 S_cv_dump(pTHX_ const CV *cv, const char *title)
1896 const CV * const outside = CvOUTSIDE(cv);
1897 AV* const padlist = CvPADLIST(cv);
1899 PERL_ARGS_ASSERT_CV_DUMP;
1901 PerlIO_printf(Perl_debug_log,
1902 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1905 (CvANON(cv) ? "ANON"
1906 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1907 : (cv == PL_main_cv) ? "MAIN"
1908 : CvUNIQUE(cv) ? "UNIQUE"
1909 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1912 : CvANON(outside) ? "ANON"
1913 : (outside == PL_main_cv) ? "MAIN"
1914 : CvUNIQUE(outside) ? "UNIQUE"
1915 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1917 PerlIO_printf(Perl_debug_log,
1918 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1919 do_dump_pad(1, Perl_debug_log, padlist, 1);
1922 #endif /* DEBUGGING */
1925 =for apidoc Am|CV *|cv_clone|CV *proto
1927 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1928 of the function: its code, pad structure, and other attributes.
1929 The prototype is combined with a capture of outer lexicals to which the
1930 code refers, which are taken from the currently-executing instance of
1931 the immediately surrounding code.
1937 Perl_cv_clone(pTHX_ CV *proto)
1941 AV* const protopadlist = CvPADLIST(proto);
1942 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1943 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1944 SV** const pname = AvARRAY(protopad_name);
1945 SV** const ppad = AvARRAY(protopad);
1946 const I32 fname = AvFILLp(protopad_name);
1947 const I32 fpad = AvFILLp(protopad);
1953 PERL_ARGS_ASSERT_CV_CLONE;
1955 assert(!CvUNIQUE(proto));
1957 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1958 * reliable. The currently-running sub is always the one we need to
1960 * Note that in general for formats, CvOUTSIDE != find_runcv.
1961 * Since formats may be nested inside closures, CvOUTSIDE may point
1962 * to a prototype; we instead want the cloned parent who called us.
1965 if (SvTYPE(proto) == SVt_PVCV)
1966 outside = find_runcv(NULL);
1968 outside = CvOUTSIDE(proto);
1969 if (CvCLONE(outside) && ! CvCLONED(outside)) {
1970 CV * const runcv = find_runcv_where(
1971 FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
1973 if (runcv) outside = runcv;
1976 depth = CvDEPTH(outside);
1977 assert(depth || SvTYPE(proto) == SVt_PVFM);
1980 assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
1983 SAVESPTR(PL_compcv);
1985 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1986 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1990 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1992 CvGV_set(cv,CvGV(proto));
1993 CvSTASH_set(cv, CvSTASH(proto));
1995 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1997 CvSTART(cv) = CvSTART(proto);
1999 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2000 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2003 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2005 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2007 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2009 av_fill(PL_comppad, fpad);
2010 for (ix = fname; ix > 0; ix--)
2011 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
2013 PL_curpad = AvARRAY(PL_comppad);
2015 outpad = CvPADLIST(outside)
2016 ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
2018 assert(outpad || SvTYPE(cv) == SVt_PVFM);
2020 for (ix = fpad; ix > 0; ix--) {
2021 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2023 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2024 if (SvFAKE(namesv)) { /* lexical from outside? */
2025 /* formats may have an inactive, or even undefined, parent;
2026 but state vars are always available. */
2027 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2028 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2029 && !CvDEPTH(outside)) ) {
2030 assert(SvTYPE(cv) == SVt_PVFM);
2031 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2032 "Variable \"%"SVf"\" is not available", namesv);
2036 SvREFCNT_inc_simple_void_NN(sv);
2039 const char sigil = SvPVX_const(namesv)[0];
2041 sv = SvREFCNT_inc(ppad[ix]);
2042 else if (sigil == '@')
2043 sv = MUTABLE_SV(newAV());
2044 else if (sigil == '%')
2045 sv = MUTABLE_SV(newHV());
2049 /* reset the 'assign only once' flag on each state var */
2050 if (SvPAD_STATE(namesv))
2054 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2055 sv = SvREFCNT_inc_NN(ppad[ix]);
2065 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2066 cv_dump(outside, "Outside");
2067 cv_dump(proto, "Proto");
2074 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2075 * The prototype was marked as a candiate for const-ization,
2076 * so try to grab the current const value, and if successful,
2077 * turn into a const sub:
2079 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2082 /* For this calling case, op_const_sv returns a *copy*, which we
2083 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2084 Need to fix how lib/constant.pm works to eliminate this. */
2085 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2096 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2098 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2099 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2100 moved to a pre-existing CV struct.
2106 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2110 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2111 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2112 SV ** const namepad = AvARRAY(comppad_name);
2113 SV ** const curpad = AvARRAY(comppad);
2115 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2116 PERL_UNUSED_ARG(old_cv);
2118 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2119 const SV * const namesv = namepad[ix];
2120 if (namesv && namesv != &PL_sv_undef
2121 && *SvPVX_const(namesv) == '&')
2123 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2124 CV * const innercv = MUTABLE_CV(curpad[ix]);
2125 assert(CvWEAKOUTSIDE(innercv));
2126 assert(CvOUTSIDE(innercv) == old_cv);
2127 CvOUTSIDE(innercv) = new_cv;
2129 else { /* format reference */
2130 SV * const rv = curpad[ix];
2132 if (!SvOK(rv)) continue;
2134 assert(SvWEAKREF(rv));
2135 innercv = (CV *)SvRV(rv);
2136 assert(!CvWEAKOUTSIDE(innercv));
2137 SvREFCNT_dec(CvOUTSIDE(innercv));
2138 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2145 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2147 Push a new pad frame onto the padlist, unless there's already a pad at
2148 this depth, in which case don't bother creating a new one. Then give
2149 the new pad an @_ in slot zero.
2155 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2159 PERL_ARGS_ASSERT_PAD_PUSH;
2161 if (depth > AvFILLp(padlist)) {
2162 SV** const svp = AvARRAY(padlist);
2163 AV* const newpad = newAV();
2164 SV** const oldpad = AvARRAY(svp[depth-1]);
2165 I32 ix = AvFILLp((const AV *)svp[1]);
2166 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2167 SV** const names = AvARRAY(svp[0]);
2170 for ( ;ix > 0; ix--) {
2171 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2172 const char sigil = SvPVX_const(names[ix])[0];
2173 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2174 || (SvFLAGS(names[ix]) & SVpad_STATE)
2177 /* outer lexical or anon code */
2178 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2180 else { /* our own lexical */
2183 sv = MUTABLE_SV(newAV());
2184 else if (sigil == '%')
2185 sv = MUTABLE_SV(newHV());
2188 av_store(newpad, ix, sv);
2192 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2193 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2196 /* save temporaries on recursion? */
2197 SV * const sv = newSV(0);
2198 av_store(newpad, ix, sv);
2203 av_store(newpad, 0, MUTABLE_SV(av));
2206 av_store(padlist, depth, MUTABLE_SV(newpad));
2207 AvFILLp(padlist) = depth;
2212 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2214 Looks up the type of the lexical variable at position I<po> in the
2215 currently-compiling pad. If the variable is typed, the stash of the
2216 class to which it is typed is returned. If not, C<NULL> is returned.
2222 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2225 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2226 if ( SvPAD_TYPED(*av) ) {
2227 return SvSTASH(*av);
2232 #if defined(USE_ITHREADS)
2234 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2237 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2245 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2248 PERL_ARGS_ASSERT_PADLIST_DUP;
2253 if (param->flags & CLONEf_COPY_STACKS
2254 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2255 dstpad = av_dup_inc(srcpad, param);
2256 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2258 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2259 to build anything other than the first level of pads. */
2261 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2263 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2264 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2265 SV **oldpad = AvARRAY(srcpad1);
2269 /* Look for it in the table first, as the padlist may have ended up
2270 as an element of @DB::args (or theoretically even @_), so it may
2271 may have been cloned already. */
2272 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2275 return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2278 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2279 av_extend(dstpad, 1);
2280 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2281 names = AvARRAY(AvARRAY(dstpad)[0]);
2285 av_extend(pad1, ix);
2286 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2287 pad1a = AvARRAY(pad1);
2288 AvFILLp(dstpad) = 1;
2293 for ( ;ix > 0; ix--) {
2296 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2297 const char sigil = SvPVX_const(names[ix])[0];
2298 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2299 || (SvFLAGS(names[ix]) & SVpad_STATE)
2302 /* outer lexical or anon code */
2303 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2305 else { /* our own lexical */
2306 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2307 /* This is a work around for how the current
2308 implementation of ?{ } blocks in regexps
2309 interacts with lexicals. */
2310 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2315 sv = MUTABLE_SV(newAV());
2316 else if (sigil == '%')
2317 sv = MUTABLE_SV(newHV());
2325 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2326 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2329 /* save temporaries on recursion? */
2330 SV * const sv = newSV(0);
2333 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2334 FIXTHAT before merging this branch.
2335 (And I know how to) */
2336 if (SvPADMY(oldpad[ix]))
2344 args = newAV(); /* Will be @_ */
2346 pad1a[0] = (SV *)args;
2354 #endif /* USE_ITHREADS */
2358 * c-indentation-style: bsd
2360 * indent-tabs-mode: nil
2363 * ex: set ts=8 sts=4 sw=4 et: