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</PadlistNAMES>.
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 PADNAME_OUTER (SvFAKE) is set on the
89 name SV, then that slot in the frame AV is
90 a REFCNT'ed reference to a lexical from "outside". In this case,
91 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
92 in scope throughout. Instead xhigh stores some flags containing info about
93 the real lexical (is it declared in an anon, and is it capable of being
94 instantiated multiple times?), and for fake ANONs, xlow contains the index
95 within the parent's pad where the lexical's value is stored, to make
98 If the 'name' is '&' the corresponding entry in the PAD
99 is a CV representing a possible closure.
100 (PADNAME_OUTER and name of '&' is not a
101 meaningful combination currently but could
102 become so if C<my sub foo {}> is implemented.)
104 Note that formats are treated as anon subs, and are cloned each time
105 write is called (if necessary).
107 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
108 and set on scope exit. This allows the
109 'Variable $x is not available' warning
110 to be generated in evals, such as
112 { my $x = 1; sub f { eval '$x'} } f();
114 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
116 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
118 During compilation, this points to the array containing the names part
119 of the pad for the currently-compiling code.
121 =for apidoc AmxU|PAD *|PL_comppad
123 During compilation, this points to the array containing the values
124 part of the pad for the currently-compiling code. (At runtime a CV may
125 have many such value arrays; at compile time just one is constructed.)
126 At runtime, this points to the array containing the currently-relevant
127 values for the pad for the currently-executing code.
129 =for apidoc AmxU|SV **|PL_curpad
131 Points directly to the body of the L</PL_comppad> array.
132 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
139 #define PERL_IN_PAD_C
141 #include "keywords.h"
143 #define COP_SEQ_RANGE_LOW_set(sv,val) \
144 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
145 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
148 #define PARENT_PAD_INDEX_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
154 =for apidoc mx|void|pad_peg|const char *s
156 When PERL_MAD is enabled, this is a small no-op function that gets called
157 at the start of each pad-related function. It can be breakpointed to
158 track all pad operations. The parameter is a string indicating the type
159 of pad operation being performed.
165 void pad_peg(const char* s) {
166 static int pegcnt; /* XXX not threadsafe */
169 PERL_ARGS_ASSERT_PAD_PEG;
176 This is basically sv_eq_flags() in sv.c, but we avoid the magic
181 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
182 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
183 const char *pv1 = SvPVX_const(sv);
184 STRLEN cur1 = SvCUR(sv);
185 const char *pv2 = pv;
190 svrecode = newSVpvn(pv2, cur2);
191 sv_recode_to_utf8(svrecode, PL_encoding);
192 pv2 = SvPV_const(svrecode, cur2);
195 svrecode = newSVpvn(pv1, cur1);
196 sv_recode_to_utf8(svrecode, PL_encoding);
197 pv1 = SvPV_const(svrecode, cur1);
199 SvREFCNT_dec(svrecode);
201 if (flags & SVf_UTF8)
202 return (bytes_cmp_utf8(
203 (const U8*)pv1, cur1,
204 (const U8*)pv2, cur2) == 0);
206 return (bytes_cmp_utf8(
207 (const U8*)pv2, cur2,
208 (const U8*)pv1, cur1) == 0);
211 return ((SvPVX_const(sv) == pv)
212 || memEQ(SvPVX_const(sv), pv, pvlen));
217 =for apidoc Am|PADLIST *|pad_new|int flags
219 Create a new padlist, updating the global variables for the
220 currently-compiling padlist to point to the new padlist. The following
221 flags can be OR'ed together:
223 padnew_CLONE this pad is for a cloned CV
224 padnew_SAVE save old globals on the save stack
225 padnew_SAVESUB also save extra stuff for start of sub
231 Perl_pad_new(pTHX_ int flags)
238 ASSERT_CURPAD_LEGAL("pad_new");
240 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
241 * vars (based on flags) rather than storing vals + addresses for
242 * each individually. Also see pad_block_start.
243 * XXX DAPM Try to see whether all these conditionals are required
246 /* save existing state, ... */
248 if (flags & padnew_SAVE) {
250 SAVESPTR(PL_comppad_name);
251 if (! (flags & padnew_CLONE)) {
253 SAVEI32(PL_comppad_name_fill);
254 SAVEI32(PL_min_intro_pending);
255 SAVEI32(PL_max_intro_pending);
256 SAVEBOOL(PL_cv_has_eval);
257 if (flags & padnew_SAVESUB) {
258 SAVEBOOL(PL_pad_reset_pending);
262 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
263 * saved - check at some pt that this is okay */
265 /* ... create new pad ... */
267 Newxz(padlist, 1, PADLIST);
270 if (flags & padnew_CLONE) {
271 /* XXX DAPM I dont know why cv_clone needs it
272 * doing differently yet - perhaps this separate branch can be
273 * dispensed with eventually ???
276 AV * const a0 = newAV(); /* will be @_ */
277 av_store(pad, 0, MUTABLE_SV(a0));
280 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
283 padlist->xpadl_id = PL_padlist_generation++;
284 av_store(pad, 0, NULL);
288 /* Most subroutines never recurse, hence only need 2 entries in the padlist
289 array - names, and depth=1. The default for av_store() is to allocate
290 0..3, and even an explicit call to av_extend() with <3 will be rounded
291 up, so we inline the allocation of the array here. */
293 PadlistMAX(padlist) = 1;
294 PadlistARRAY(padlist) = ary;
298 /* ... then update state variables */
301 PL_curpad = AvARRAY(pad);
303 if (! (flags & padnew_CLONE)) {
304 PL_comppad_name = padname;
305 PL_comppad_name_fill = 0;
306 PL_min_intro_pending = 0;
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
312 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
313 " name=0x%"UVxf" flags=0x%"UVxf"\n",
314 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
315 PTR2UV(padname), (UV)flags
319 return (PADLIST*)padlist;
324 =head1 Embedding Functions
328 Clear out all the active components of a CV. This can happen either
329 by an explicit C<undef &foo>, or by the reference count going to zero.
330 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
331 children can still follow the full lexical scope chain.
337 Perl_cv_undef(pTHX_ CV *cv)
340 const PADLIST *padlist = CvPADLIST(cv);
341 bool const slabbed = !!CvSLABBED(cv);
343 PERL_ARGS_ASSERT_CV_UNDEF;
345 DEBUG_X(PerlIO_printf(Perl_debug_log,
346 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
347 PTR2UV(cv), PTR2UV(PL_comppad))
350 if (CvFILE(cv) && CvDYNFILE(cv)) {
351 Safefree(CvFILE(cv));
356 if (!CvISXSUB(cv) && CvROOT(cv)) {
357 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
358 Perl_croak(aTHX_ "Can't undef active subroutine");
361 PAD_SAVE_SETNULLPAD();
363 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
369 else if (slabbed && CvSTART(cv)) {
371 PAD_SAVE_SETNULLPAD();
373 /* discard any leaked ops */
374 opslab_force_free((OPSLAB *)CvSTART(cv));
380 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
382 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
383 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
386 /* This statement and the subsequence if block was pad_undef(). */
387 pad_peg("pad_undef");
392 /* Free the padlist associated with a CV.
393 If parts of it happen to be current, we null the relevant PL_*pad*
394 global vars so that we don't have any dangling references left.
395 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
396 subs to the outer of this cv. */
398 DEBUG_X(PerlIO_printf(Perl_debug_log,
399 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
400 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
403 /* detach any '&' anon children in the pad; if afterwards they
404 * are still live, fix up their CvOUTSIDEs to point to our outside,
406 /* XXX DAPM for efficiency, we should only do this if we know we have
407 * children, or integrate this loop with general cleanup */
409 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
410 CV * const outercv = CvOUTSIDE(cv);
411 const U32 seq = CvOUTSIDE_SEQ(cv);
412 PAD * const comppad_name = PadlistARRAY(padlist)[0];
413 SV ** const namepad = AvARRAY(comppad_name);
414 PAD * const comppad = PadlistARRAY(padlist)[1];
415 SV ** const curpad = AvARRAY(comppad);
416 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
417 SV * const namesv = namepad[ix];
418 if (namesv && namesv != &PL_sv_undef
419 && *SvPVX_const(namesv) == '&')
421 CV * const innercv = MUTABLE_CV(curpad[ix]);
422 U32 inner_rc = SvREFCNT(innercv);
424 assert(SvTYPE(innercv) != SVt_PVFM);
426 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
428 SvREFCNT_dec(innercv);
432 /* in use, not just a prototype */
433 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
434 assert(CvWEAKOUTSIDE(innercv));
435 /* don't relink to grandfather if he's being freed */
436 if (outercv && SvREFCNT(outercv)) {
437 CvWEAKOUTSIDE_off(innercv);
438 CvOUTSIDE(innercv) = outercv;
439 CvOUTSIDE_SEQ(innercv) = seq;
440 SvREFCNT_inc_simple_void_NN(outercv);
443 CvOUTSIDE(innercv) = NULL;
450 ix = PadlistMAX(padlist);
452 PAD * const sv = PadlistARRAY(padlist)[ix--];
454 if (sv == PL_comppad) {
462 PAD * const sv = PadlistARRAY(padlist)[0];
463 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
464 PL_comppad_name = NULL;
467 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
469 CvPADLIST(cv) = NULL;
473 /* remove CvOUTSIDE unless this is an undef rather than a free */
474 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
475 if (!CvWEAKOUTSIDE(cv))
476 SvREFCNT_dec(CvOUTSIDE(cv));
477 CvOUTSIDE(cv) = NULL;
480 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
483 if (CvISXSUB(cv) && CvXSUB(cv)) {
486 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
487 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
488 * to choose an error message */
489 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
493 =for apidoc cv_forget_slab
495 When a CV has a reference count on its slab (CvSLABBED), it is responsible
496 for making sure it is freed. (Hence, no two CVs should ever have a
497 reference count on the same slab.) The CV only needs to reference the slab
498 during compilation. Once it is compiled and CvROOT attached, it has
499 finished its job, so it can forget the slab.
505 Perl_cv_forget_slab(pTHX_ CV *cv)
507 const bool slabbed = !!CvSLABBED(cv);
510 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
512 if (!slabbed) return;
516 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
517 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
519 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
523 #ifdef PERL_DEBUG_READONLY_OPS
524 const size_t refcnt = slab->opslab_refcnt;
526 OpslabREFCNT_dec(slab);
527 #ifdef PERL_DEBUG_READONLY_OPS
528 if (refcnt > 1) Slab_to_ro(slab);
534 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
536 Allocates a place in the currently-compiling
537 pad (via L<perlapi/pad_alloc>) and
538 then stores a name for that entry. I<namesv> is adopted and becomes the
539 name entry; it must already contain the name string and be sufficiently
540 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
541 added to I<namesv>. None of the other
542 processing of L<perlapi/pad_add_name_pvn>
543 is done. Returns the offset of the allocated pad slot.
549 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
552 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
554 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
556 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
559 assert(SvTYPE(namesv) == SVt_PVMG);
560 SvPAD_TYPED_on(namesv);
561 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
564 SvPAD_OUR_on(namesv);
565 SvOURSTASH_set(namesv, ourstash);
566 SvREFCNT_inc_simple_void_NN(ourstash);
568 else if (flags & padadd_STATE) {
569 SvPAD_STATE_on(namesv);
572 av_store(PL_comppad_name, offset, namesv);
577 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
579 Allocates a place in the currently-compiling pad for a named lexical
580 variable. Stores the name and other metadata in the name part of the
581 pad, and makes preparations to manage the variable's lexical scoping.
582 Returns the offset of the allocated pad slot.
584 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
585 If I<typestash> is non-null, the name is for a typed lexical, and this
586 identifies the type. If I<ourstash> is non-null, it's a lexical reference
587 to a package variable, and this identifies the package. The following
588 flags can be OR'ed together:
590 padadd_OUR redundantly specifies if it's a package var
591 padadd_STATE variable will retain value persistently
592 padadd_NO_DUP_CHECK skip check for lexical shadowing
598 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
599 U32 flags, HV *typestash, HV *ourstash)
606 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
608 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
609 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
612 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
614 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
615 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
618 sv_setpvn(namesv, namepv, namelen);
621 flags |= padadd_UTF8_NAME;
625 flags &= ~padadd_UTF8_NAME;
627 if ((flags & padadd_NO_DUP_CHECK) == 0) {
628 /* check for duplicate declaration */
629 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
632 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
634 /* not yet introduced */
635 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
636 COP_SEQ_RANGE_HIGH_set(namesv, 0);
638 if (!PL_min_intro_pending)
639 PL_min_intro_pending = offset;
640 PL_max_intro_pending = offset;
641 /* if it's not a simple scalar, replace with an AV or HV */
642 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
643 assert(SvREFCNT(PL_curpad[offset]) == 1);
644 if (namelen != 0 && *namepv == '@')
645 sv_upgrade(PL_curpad[offset], SVt_PVAV);
646 else if (namelen != 0 && *namepv == '%')
647 sv_upgrade(PL_curpad[offset], SVt_PVHV);
648 assert(SvPADMY(PL_curpad[offset]));
649 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
650 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
651 (long)offset, SvPVX(namesv),
652 PTR2UV(PL_curpad[offset])));
658 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
660 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
661 instead of a string/length pair.
667 Perl_pad_add_name_pv(pTHX_ const char *name,
668 const U32 flags, HV *typestash, HV *ourstash)
670 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
671 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
675 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
677 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
678 of an SV instead of a string/length pair.
684 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
688 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
689 namepv = SvPV(name, namelen);
691 flags |= padadd_UTF8_NAME;
692 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
696 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
698 Allocates a place in the currently-compiling pad,
699 returning the offset of the allocated pad slot.
700 No name is initially attached to the pad slot.
701 I<tmptype> is a set of flags indicating the kind of pad entry required,
702 which will be set in the value SV for the allocated pad entry:
704 SVs_PADMY named lexical variable ("my", "our", "state")
705 SVs_PADTMP unnamed temporary store
707 I<optype> should be an opcode indicating the type of operation that the
708 pad entry is to support. This doesn't affect operational semantics,
709 but is used for debugging.
714 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
715 * or at least rationalise ??? */
718 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
724 PERL_UNUSED_ARG(optype);
725 ASSERT_CURPAD_ACTIVE("pad_alloc");
727 if (AvARRAY(PL_comppad) != PL_curpad)
728 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
729 AvARRAY(PL_comppad), PL_curpad);
730 if (PL_pad_reset_pending)
732 if (tmptype & SVs_PADMY) {
733 /* For a my, simply push a null SV onto the end of PL_comppad. */
734 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
735 retval = AvFILLp(PL_comppad);
738 /* For a tmp, scan the pad from PL_padix upwards
739 * for a slot which has no name and no active value.
741 SV * const * const names = AvARRAY(PL_comppad_name);
742 const SSize_t names_fill = AvFILLp(PL_comppad_name);
745 * "foreach" index vars temporarily become aliases to non-"my"
746 * values. Thus we must skip, not just pad values that are
747 * marked as current pad values, but also those with names.
749 /* HVDS why copy to sv here? we don't seem to use it */
750 if (++PL_padix <= names_fill &&
751 (sv = names[PL_padix]) && sv != &PL_sv_undef)
753 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
754 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
755 !IS_PADGV(sv) && !IS_PADCONST(sv))
760 SvFLAGS(sv) |= tmptype;
761 PL_curpad = AvARRAY(PL_comppad);
763 DEBUG_X(PerlIO_printf(Perl_debug_log,
764 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
765 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
766 PL_op_name[optype]));
767 #ifdef DEBUG_LEAKING_SCALARS
768 sv->sv_debug_optype = optype;
769 sv->sv_debug_inpad = 1;
771 return (PADOFFSET)retval;
775 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
777 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
778 for an anonymous function that is lexically scoped inside the
779 currently-compiling function.
780 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
781 to the outer scope is weakened to avoid a reference loop.
783 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
785 I<optype> should be an opcode indicating the type of operation that the
786 pad entry is to support. This doesn't affect operational semantics,
787 but is used for debugging.
793 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
797 SV* const name = newSV_type(SVt_PVNV);
799 PERL_ARGS_ASSERT_PAD_ADD_ANON;
802 sv_setpvs(name, "&");
803 /* These two aren't used; just make sure they're not equal to
804 * PERL_PADSEQ_INTRO */
805 COP_SEQ_RANGE_LOW_set(name, 0);
806 COP_SEQ_RANGE_HIGH_set(name, 0);
807 ix = pad_alloc(optype, SVs_PADMY);
808 av_store(PL_comppad_name, ix, name);
809 /* XXX DAPM use PL_curpad[] ? */
810 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
811 av_store(PL_comppad, ix, (SV*)func);
813 SV *rv = newRV_noinc((SV *)func);
815 assert (SvTYPE(func) == SVt_PVFM);
816 av_store(PL_comppad, ix, rv);
818 SvPADMY_on((SV*)func);
820 /* to avoid ref loops, we never have parent + child referencing each
821 * other simultaneously */
822 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
823 assert(!CvWEAKOUTSIDE(func));
824 CvWEAKOUTSIDE_on(func);
825 SvREFCNT_dec(CvOUTSIDE(func));
831 =for apidoc pad_check_dup
833 Check for duplicate declarations: report any of:
835 * a my in the current scope with the same name;
836 * an our (anywhere in the pad) with the same name and the
837 same stash as C<ourstash>
839 C<is_our> indicates that the name to check is an 'our' declaration.
845 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
850 const U32 is_our = flags & padadd_OUR;
852 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
854 ASSERT_CURPAD_ACTIVE("pad_check_dup");
856 assert((flags & ~padadd_OUR) == 0);
858 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
859 return; /* nothing to check */
861 svp = AvARRAY(PL_comppad_name);
862 top = AvFILLp(PL_comppad_name);
863 /* check the current scope */
864 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
866 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
867 SV * const sv = svp[off];
869 && sv != &PL_sv_undef
871 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
872 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
875 if (is_our && (SvPAD_OUR(sv)))
876 break; /* "our" masking "our" */
877 Perl_warner(aTHX_ packWARN(WARN_MISC),
878 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
879 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
881 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
882 ? "scope" : "statement"));
887 /* check the rest of the pad */
890 SV * const sv = svp[off];
892 && sv != &PL_sv_undef
894 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
895 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
896 && SvOURSTASH(sv) == ourstash
899 Perl_warner(aTHX_ packWARN(WARN_MISC),
900 "\"our\" variable %"SVf" redeclared", sv);
901 if ((I32)off <= PL_comppad_name_floor)
902 Perl_warner(aTHX_ packWARN(WARN_MISC),
903 "\t(Did you mean \"local\" instead of \"our\"?)\n");
913 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
915 Given the name of a lexical variable, find its position in the
916 currently-compiling pad.
917 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
918 I<flags> is reserved and must be zero.
919 If it is not in the current pad but appears in the pad of any lexically
920 enclosing scope, then a pseudo-entry for it is added in the current pad.
921 Returns the offset in the current pad,
922 or C<NOT_IN_PAD> if no such lexical is in scope.
928 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
937 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
939 pad_peg("pad_findmy_pvn");
941 if (flags & ~padadd_UTF8_NAME)
942 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
945 if (flags & padadd_UTF8_NAME) {
947 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
950 flags |= padadd_UTF8_NAME;
952 flags &= ~padadd_UTF8_NAME;
955 offset = pad_findlex(namepv, namelen, flags,
956 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
957 if ((PADOFFSET)offset != NOT_IN_PAD)
960 /* look for an our that's being introduced; this allows
961 * our $foo = 0 unless defined $foo;
962 * to not give a warning. (Yes, this is a hack) */
964 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
965 name_svp = AvARRAY(nameav);
966 for (offset = AvFILLp(nameav); offset > 0; offset--) {
967 const SV * const namesv = name_svp[offset];
968 if (namesv && namesv != &PL_sv_undef
970 && (SvPAD_OUR(namesv))
971 && SvCUR(namesv) == namelen
972 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
973 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
974 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
982 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
984 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
985 instead of a string/length pair.
991 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
993 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
994 return pad_findmy_pvn(name, strlen(name), flags);
998 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1000 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1001 of an SV instead of a string/length pair.
1007 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1011 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1012 namepv = SvPV(name, namelen);
1014 flags |= padadd_UTF8_NAME;
1015 return pad_findmy_pvn(namepv, namelen, flags);
1019 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1021 Find the position of the lexical C<$_> in the pad of the
1022 currently-executing function. Returns the offset in the current pad,
1023 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1024 the global one should be used instead).
1025 L</find_rundefsv> is likely to be more convenient.
1031 Perl_find_rundefsvoffset(pTHX)
1036 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1037 NULL, &out_sv, &out_flags);
1041 =for apidoc Am|SV *|find_rundefsv
1043 Find and return the variable that is named C<$_> in the lexical scope
1044 of the currently-executing function. This may be a lexical C<$_>,
1045 or will otherwise be the global one.
1051 Perl_find_rundefsv(pTHX)
1057 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1058 NULL, &namesv, &flags);
1060 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1067 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1073 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1075 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1076 NULL, &namesv, &flags);
1078 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1081 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1085 =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
1087 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1088 in the inner pads if it's found in an outer one.
1090 Returns the offset in the bottom pad of the lex or the fake lex.
1091 cv is the CV in which to start the search, and seq is the current cop_seq
1092 to match against. If warn is true, print appropriate warnings. The out_*
1093 vars return values, and so are pointers to where the returned values
1094 should be stored. out_capture, if non-null, requests that the innermost
1095 instance of the lexical is captured; out_name_sv is set to the innermost
1096 matched namesv or fake namesv; out_flags returns the flags normally
1097 associated with the IVX field of a fake namesv.
1099 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1100 then comes back down, adding fake entries as it goes. It has to be this way
1101 because fake namesvs in anon protoypes have to store in xlow the index into
1107 /* the CV has finished being compiled. This is not a sufficient test for
1108 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1109 #define CvCOMPILED(cv) CvROOT(cv)
1111 /* the CV does late binding of its lexicals */
1112 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1116 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1117 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1120 I32 offset, new_offset;
1123 const PADLIST * const padlist = CvPADLIST(cv);
1124 const bool staleok = !!(flags & padadd_STALEOK);
1126 PERL_ARGS_ASSERT_PAD_FINDLEX;
1128 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1129 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1131 flags &= ~ padadd_STALEOK; /* one-shot flag */
1135 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1136 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1137 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1138 out_capture ? " capturing" : "" ));
1140 /* first, search this pad */
1142 if (padlist) { /* not an undef CV */
1143 I32 fake_offset = 0;
1144 const AV * const nameav = PadlistARRAY(padlist)[0];
1145 SV * const * const name_svp = AvARRAY(nameav);
1147 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1148 const SV * const namesv = name_svp[offset];
1149 if (namesv && namesv != &PL_sv_undef
1150 && SvCUR(namesv) == namelen
1151 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1152 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1154 if (SvFAKE(namesv)) {
1155 fake_offset = offset; /* in case we don't find a real one */
1158 /* is seq within the range _LOW to _HIGH ?
1159 * This is complicated by the fact that PL_cop_seqmax
1160 * may have wrapped around at some point */
1161 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1162 continue; /* not yet introduced */
1164 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1165 /* in compiling scope */
1167 (seq > COP_SEQ_RANGE_LOW(namesv))
1168 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1169 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1174 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1176 ( seq > COP_SEQ_RANGE_LOW(namesv)
1177 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1179 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1180 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1186 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1187 if (offset > 0) { /* not fake */
1189 *out_name_sv = name_svp[offset]; /* return the namesv */
1191 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1192 * instances. For now, we just test !CvUNIQUE(cv), but
1193 * ideally, we should detect my's declared within loops
1194 * etc - this would allow a wider range of 'not stayed
1195 * shared' warnings. We also treated already-compiled
1196 * lexes as not multi as viewed from evals. */
1198 *out_flags = CvANON(cv) ?
1200 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1201 ? PAD_FAKELEX_MULTI : 0;
1203 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1204 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1205 PTR2UV(cv), (long)offset,
1206 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1207 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1209 else { /* fake match */
1210 offset = fake_offset;
1211 *out_name_sv = name_svp[offset]; /* return the namesv */
1212 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1213 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1214 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1215 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1216 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1220 /* return the lex? */
1225 if (SvPAD_OUR(*out_name_sv)) {
1226 *out_capture = NULL;
1230 /* trying to capture from an anon prototype? */
1232 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1233 : *out_flags & PAD_FAKELEX_ANON)
1236 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1237 "Variable \"%"SVf"\" is not available",
1238 newSVpvn_flags(namepv, namelen,
1240 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1242 *out_capture = NULL;
1248 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1249 && !SvPAD_STATE(name_svp[offset])
1250 && warn && ckWARN(WARN_CLOSURE)) {
1252 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1253 "Variable \"%"SVf"\" will not stay shared",
1254 newSVpvn_flags(namepv, namelen,
1256 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1259 if (fake_offset && CvANON(cv)
1260 && CvCLONE(cv) &&!CvCLONED(cv))
1263 /* not yet caught - look further up */
1264 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1265 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1268 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1270 newwarn, out_capture, out_name_sv, out_flags);
1275 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1276 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1277 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1278 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1279 PTR2UV(cv), PTR2UV(*out_capture)));
1281 if (SvPADSTALE(*out_capture)
1282 && (!CvDEPTH(cv) || !staleok)
1283 && !SvPAD_STATE(name_svp[offset]))
1285 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1286 "Variable \"%"SVf"\" is not available",
1287 newSVpvn_flags(namepv, namelen,
1289 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1290 *out_capture = NULL;
1293 if (!*out_capture) {
1294 if (namelen != 0 && *namepv == '@')
1295 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1296 else if (namelen != 0 && *namepv == '%')
1297 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1299 *out_capture = sv_newmortal();
1307 /* it's not in this pad - try above */
1312 /* out_capture non-null means caller wants us to capture lex; in
1313 * addition we capture ourselves unless it's an ANON/format */
1314 new_capturep = out_capture ? out_capture :
1315 CvLATE(cv) ? NULL : &new_capture;
1317 offset = pad_findlex(namepv, namelen,
1318 flags | padadd_STALEOK*(new_capturep == &new_capture),
1319 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1320 new_capturep, out_name_sv, out_flags);
1321 if ((PADOFFSET)offset == NOT_IN_PAD)
1324 /* found in an outer CV. Add appropriate fake entry to this pad */
1326 /* don't add new fake entries (via eval) to CVs that we have already
1327 * finished compiling, or to undef CVs */
1328 if (CvCOMPILED(cv) || !padlist)
1329 return 0; /* this dummy (and invalid) value isnt used by the caller */
1332 /* This relies on sv_setsv_flags() upgrading the destination to the same
1333 type as the source, independent of the flags set, and on it being
1334 "good" and only copying flag bits and pointers that it understands.
1336 SV *new_namesv = newSVsv(*out_name_sv);
1337 AV * const ocomppad_name = PL_comppad_name;
1338 PAD * const ocomppad = PL_comppad;
1339 PL_comppad_name = PadlistARRAY(padlist)[0];
1340 PL_comppad = PadlistARRAY(padlist)[1];
1341 PL_curpad = AvARRAY(PL_comppad);
1344 = pad_alloc_name(new_namesv,
1345 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1346 SvPAD_TYPED(*out_name_sv)
1347 ? SvSTASH(*out_name_sv) : NULL,
1348 SvOURSTASH(*out_name_sv)
1351 SvFAKE_on(new_namesv);
1352 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1353 "Pad addname: %ld \"%.*s\" FAKE\n",
1355 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1356 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1358 PARENT_PAD_INDEX_set(new_namesv, 0);
1359 if (SvPAD_OUR(new_namesv)) {
1360 NOOP; /* do nothing */
1362 else if (CvLATE(cv)) {
1363 /* delayed creation - just note the offset within parent pad */
1364 PARENT_PAD_INDEX_set(new_namesv, offset);
1368 /* immediate creation - capture outer value right now */
1369 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1370 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1371 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1372 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1374 *out_name_sv = new_namesv;
1375 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1377 PL_comppad_name = ocomppad_name;
1378 PL_comppad = ocomppad;
1379 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1387 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1389 Get the value at offset I<po> in the current (compiling or executing) pad.
1390 Use macro PAD_SV instead of calling this function directly.
1396 Perl_pad_sv(pTHX_ PADOFFSET po)
1399 ASSERT_CURPAD_ACTIVE("pad_sv");
1402 Perl_croak(aTHX_ "panic: pad_sv po");
1403 DEBUG_X(PerlIO_printf(Perl_debug_log,
1404 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1405 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1407 return PL_curpad[po];
1411 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1413 Set the value at offset I<po> in the current (compiling or executing) pad.
1414 Use the macro PAD_SETSV() rather than calling this function directly.
1420 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1424 PERL_ARGS_ASSERT_PAD_SETSV;
1426 ASSERT_CURPAD_ACTIVE("pad_setsv");
1428 DEBUG_X(PerlIO_printf(Perl_debug_log,
1429 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1430 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1435 #endif /* DEBUGGING */
1438 =for apidoc m|void|pad_block_start|int full
1440 Update the pad compilation state variables on entry to a new block.
1445 /* XXX DAPM perhaps:
1446 * - integrate this in general state-saving routine ???
1447 * - combine with the state-saving going on in pad_new ???
1448 * - introduce a new SAVE type that does all this in one go ?
1452 Perl_pad_block_start(pTHX_ int full)
1455 ASSERT_CURPAD_ACTIVE("pad_block_start");
1456 SAVEI32(PL_comppad_name_floor);
1457 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1459 PL_comppad_name_fill = PL_comppad_name_floor;
1460 if (PL_comppad_name_floor < 0)
1461 PL_comppad_name_floor = 0;
1462 SAVEI32(PL_min_intro_pending);
1463 SAVEI32(PL_max_intro_pending);
1464 PL_min_intro_pending = 0;
1465 SAVEI32(PL_comppad_name_fill);
1466 SAVEI32(PL_padix_floor);
1467 PL_padix_floor = PL_padix;
1468 PL_pad_reset_pending = FALSE;
1472 =for apidoc m|U32|intro_my
1474 "Introduce" my variables to visible status. This is called during parsing
1475 at the end of each statement to make lexical variables visible to
1476 subsequent statements.
1489 ASSERT_CURPAD_ACTIVE("intro_my");
1490 if (! PL_min_intro_pending)
1491 return PL_cop_seqmax;
1493 svp = AvARRAY(PL_comppad_name);
1494 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1495 SV * const sv = svp[i];
1497 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1498 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1500 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1501 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1502 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1503 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1504 (long)i, SvPVX_const(sv),
1505 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1506 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1510 seq = PL_cop_seqmax;
1512 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1514 PL_min_intro_pending = 0;
1515 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1516 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1517 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1523 =for apidoc m|void|pad_leavemy
1525 Cleanup at end of scope during compilation: set the max seq number for
1526 lexicals in this scope and warn of any lexicals that never got introduced.
1532 Perl_pad_leavemy(pTHX)
1536 SV * const * const svp = AvARRAY(PL_comppad_name);
1538 PL_pad_reset_pending = FALSE;
1540 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1541 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1542 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1543 const SV * const sv = svp[off];
1544 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1545 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1546 "%"SVf" never introduced",
1550 /* "Deintroduce" my variables that are leaving with this scope. */
1551 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1552 const SV * const sv = svp[off];
1553 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1554 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1556 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1557 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1558 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1559 (long)off, SvPVX_const(sv),
1560 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1561 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1566 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1568 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1569 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1573 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1575 Abandon the tmp in the current pad at offset po and replace with a
1582 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1585 ASSERT_CURPAD_LEGAL("pad_swipe");
1588 if (AvARRAY(PL_comppad) != PL_curpad)
1589 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1590 AvARRAY(PL_comppad), PL_curpad);
1591 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1592 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1593 (long)po, (long)AvFILLp(PL_comppad));
1595 DEBUG_X(PerlIO_printf(Perl_debug_log,
1596 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1597 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1600 SvPADTMP_off(PL_curpad[po]);
1602 SvREFCNT_dec(PL_curpad[po]);
1605 /* if pad tmps aren't shared between ops, then there's no need to
1606 * create a new tmp when an existing op is freed */
1607 #ifdef USE_BROKEN_PAD_RESET
1608 PL_curpad[po] = newSV(0);
1609 SvPADTMP_on(PL_curpad[po]);
1611 PL_curpad[po] = &PL_sv_undef;
1613 if ((I32)po < PL_padix)
1618 =for apidoc m|void|pad_reset
1620 Mark all the current temporaries for reuse
1625 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1626 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1627 * on the stack by OPs that use them, there are several ways to get an alias
1628 * to a shared TARG. Such an alias will change randomly and unpredictably.
1629 * We avoid doing this until we can think of a Better Way.
1635 #ifdef USE_BROKEN_PAD_RESET
1636 if (AvARRAY(PL_comppad) != PL_curpad)
1637 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1638 AvARRAY(PL_comppad), PL_curpad);
1640 DEBUG_X(PerlIO_printf(Perl_debug_log,
1641 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1642 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1643 (long)PL_padix, (long)PL_padix_floor
1647 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1649 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1650 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1651 SvPADTMP_off(PL_curpad[po]);
1653 PL_padix = PL_padix_floor;
1656 PL_pad_reset_pending = FALSE;
1660 =for apidoc Amx|void|pad_tidy|padtidy_type type
1662 Tidy up a pad at the end of compilation of the code to which it belongs.
1663 Jobs performed here are: remove most stuff from the pads of anonsub
1664 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1665 the kind of subroutine:
1667 padtidy_SUB ordinary subroutine
1668 padtidy_SUBCLONE prototype for lexical closure
1669 padtidy_FORMAT format
1674 /* XXX DAPM surely most of this stuff should be done properly
1675 * at the right time beforehand, rather than going around afterwards
1676 * cleaning up our mistakes ???
1680 Perl_pad_tidy(pTHX_ padtidy_type type)
1684 ASSERT_CURPAD_ACTIVE("pad_tidy");
1686 /* If this CV has had any 'eval-capable' ops planted in it
1687 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1688 * anon prototypes in the chain of CVs should be marked as cloneable,
1689 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1690 * the right CvOUTSIDE.
1691 * If running with -d, *any* sub may potentially have an eval
1692 * executed within it.
1695 if (PL_cv_has_eval || PL_perldb) {
1697 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1698 if (cv != PL_compcv && CvCOMPILED(cv))
1699 break; /* no need to mark already-compiled code */
1701 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1702 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1709 /* extend curpad to match namepad */
1710 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1711 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1713 if (type == padtidy_SUBCLONE) {
1714 SV * const * const namep = AvARRAY(PL_comppad_name);
1717 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1720 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1723 * The only things that a clonable function needs in its
1724 * pad are anonymous subs.
1725 * The rest are created anew during cloning.
1727 if (!((namesv = namep[ix]) != NULL &&
1728 namesv != &PL_sv_undef &&
1729 *SvPVX_const(namesv) == '&'))
1731 SvREFCNT_dec(PL_curpad[ix]);
1732 PL_curpad[ix] = NULL;
1736 else if (type == padtidy_SUB) {
1737 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1738 AV * const av = newAV(); /* Will be @_ */
1739 av_store(PL_comppad, 0, MUTABLE_SV(av));
1743 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1744 SV * const * const namep = AvARRAY(PL_comppad_name);
1746 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1747 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1749 if (!SvPADMY(PL_curpad[ix])) {
1750 SvPADTMP_on(PL_curpad[ix]);
1751 } else if (!SvFAKE(namep[ix])) {
1752 /* This is a work around for how the current implementation of
1753 ?{ } blocks in regexps interacts with lexicals.
1755 One of our lexicals.
1756 Can't do this on all lexicals, otherwise sub baz() won't
1765 because completion of compiling &bar calling pad_tidy()
1766 would cause (top level) $foo to be marked as stale, and
1767 "no longer available". */
1768 SvPADSTALE_on(PL_curpad[ix]);
1772 PL_curpad = AvARRAY(PL_comppad);
1776 =for apidoc m|void|pad_free|PADOFFSET po
1778 Free the SV at offset po in the current pad.
1783 /* XXX DAPM integrate with pad_swipe ???? */
1785 Perl_pad_free(pTHX_ PADOFFSET po)
1788 ASSERT_CURPAD_LEGAL("pad_free");
1791 if (AvARRAY(PL_comppad) != PL_curpad)
1792 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1793 AvARRAY(PL_comppad), PL_curpad);
1795 Perl_croak(aTHX_ "panic: pad_free po");
1797 DEBUG_X(PerlIO_printf(Perl_debug_log,
1798 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1799 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1802 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1803 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1805 if ((I32)po < PL_padix)
1810 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1812 Dump the contents of a padlist
1818 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1827 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1832 pad_name = *PadlistARRAY(padlist);
1833 pad = PadlistARRAY(padlist)[1];
1834 pname = AvARRAY(pad_name);
1835 ppad = AvARRAY(pad);
1836 Perl_dump_indent(aTHX_ level, file,
1837 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1838 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1841 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1842 const SV *namesv = pname[ix];
1843 if (namesv && namesv == &PL_sv_undef) {
1848 Perl_dump_indent(aTHX_ level+1, file,
1849 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1852 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1853 SvPVX_const(namesv),
1854 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1855 (unsigned long)PARENT_PAD_INDEX(namesv)
1859 Perl_dump_indent(aTHX_ level+1, file,
1860 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1863 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1864 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1865 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1870 Perl_dump_indent(aTHX_ level+1, file,
1871 "%2d. 0x%"UVxf"<%lu>\n",
1874 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1883 =for apidoc m|void|cv_dump|CV *cv|const char *title
1885 dump the contents of a CV
1891 S_cv_dump(pTHX_ const CV *cv, const char *title)
1894 const CV * const outside = CvOUTSIDE(cv);
1895 PADLIST* const padlist = CvPADLIST(cv);
1897 PERL_ARGS_ASSERT_CV_DUMP;
1899 PerlIO_printf(Perl_debug_log,
1900 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1903 (CvANON(cv) ? "ANON"
1904 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1905 : (cv == PL_main_cv) ? "MAIN"
1906 : CvUNIQUE(cv) ? "UNIQUE"
1907 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1910 : CvANON(outside) ? "ANON"
1911 : (outside == PL_main_cv) ? "MAIN"
1912 : CvUNIQUE(outside) ? "UNIQUE"
1913 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1915 PerlIO_printf(Perl_debug_log,
1916 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1917 do_dump_pad(1, Perl_debug_log, padlist, 1);
1920 #endif /* DEBUGGING */
1923 =for apidoc Am|CV *|cv_clone|CV *proto
1925 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1926 of the function: its code, pad structure, and other attributes.
1927 The prototype is combined with a capture of outer lexicals to which the
1928 code refers, which are taken from the currently-executing instance of
1929 the immediately surrounding code.
1935 Perl_cv_clone(pTHX_ CV *proto)
1939 PADLIST* const protopadlist = CvPADLIST(proto);
1940 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1941 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1942 SV** const pname = AvARRAY(protopad_name);
1943 SV** const ppad = AvARRAY(protopad);
1944 const I32 fname = AvFILLp(protopad_name);
1945 const I32 fpad = AvFILLp(protopad);
1951 PERL_ARGS_ASSERT_CV_CLONE;
1953 assert(!CvUNIQUE(proto));
1955 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1956 * reliable. The currently-running sub is always the one we need to
1958 * Note that in general for formats, CvOUTSIDE != find_runcv.
1959 * Since formats may be nested inside closures, CvOUTSIDE may point
1960 * to a prototype; we instead want the cloned parent who called us.
1963 if (SvTYPE(proto) == SVt_PVCV)
1964 outside = find_runcv(NULL);
1966 outside = CvOUTSIDE(proto);
1967 if ((CvCLONE(outside) && ! CvCLONED(outside))
1968 || !CvPADLIST(outside)
1969 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1970 outside = find_runcv_where(
1971 FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
1973 /* outside could be null */
1976 depth = outside ? CvDEPTH(outside) : 0;
1977 assert(depth || SvTYPE(proto) == SVt_PVFM);
1980 assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
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 PL_comppad_name = protopad_name;
2008 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2009 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2011 av_fill(PL_comppad, fpad);
2013 PL_curpad = AvARRAY(PL_comppad);
2015 outpad = outside && CvPADLIST(outside)
2016 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2018 assert(outpad || SvTYPE(cv) == SVt_PVFM);
2019 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2021 for (ix = fpad; ix > 0; ix--) {
2022 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2024 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2025 if (SvFAKE(namesv)) { /* lexical from outside? */
2026 /* formats may have an inactive, or even undefined, parent;
2027 but state vars are always available. */
2028 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2029 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2030 && (!outside || !CvDEPTH(outside))) ) {
2031 assert(SvTYPE(cv) == SVt_PVFM);
2032 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2033 "Variable \"%"SVf"\" is not available", namesv);
2037 SvREFCNT_inc_simple_void_NN(sv);
2040 const char sigil = SvPVX_const(namesv)[0];
2042 sv = SvREFCNT_inc(ppad[ix]);
2043 else if (sigil == '@')
2044 sv = MUTABLE_SV(newAV());
2045 else if (sigil == '%')
2046 sv = MUTABLE_SV(newHV());
2050 /* reset the 'assign only once' flag on each state var */
2051 if (SvPAD_STATE(namesv))
2055 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2056 sv = SvREFCNT_inc_NN(ppad[ix]);
2066 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2067 if (outside) cv_dump(outside, "Outside");
2068 cv_dump(proto, "Proto");
2075 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2076 * The prototype was marked as a candiate for const-ization,
2077 * so try to grab the current const value, and if successful,
2078 * turn into a const sub:
2080 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2083 /* For this calling case, op_const_sv returns a *copy*, which we
2084 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2085 Need to fix how lib/constant.pm works to eliminate this. */
2086 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2097 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2099 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2100 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2101 moved to a pre-existing CV struct.
2107 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2111 AV * const comppad_name = PadlistARRAY(padlist)[0];
2112 AV * const comppad = PadlistARRAY(padlist)[1];
2113 SV ** const namepad = AvARRAY(comppad_name);
2114 SV ** const curpad = AvARRAY(comppad);
2116 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2117 PERL_UNUSED_ARG(old_cv);
2119 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2120 const SV * const namesv = namepad[ix];
2121 if (namesv && namesv != &PL_sv_undef
2122 && *SvPVX_const(namesv) == '&')
2124 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2125 CV * const innercv = MUTABLE_CV(curpad[ix]);
2126 assert(CvWEAKOUTSIDE(innercv));
2127 assert(CvOUTSIDE(innercv) == old_cv);
2128 CvOUTSIDE(innercv) = new_cv;
2130 else { /* format reference */
2131 SV * const rv = curpad[ix];
2133 if (!SvOK(rv)) continue;
2135 assert(SvWEAKREF(rv));
2136 innercv = (CV *)SvRV(rv);
2137 assert(!CvWEAKOUTSIDE(innercv));
2138 SvREFCNT_dec(CvOUTSIDE(innercv));
2139 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2146 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2148 Push a new pad frame onto the padlist, unless there's already a pad at
2149 this depth, in which case don't bother creating a new one. Then give
2150 the new pad an @_ in slot zero.
2156 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2160 PERL_ARGS_ASSERT_PAD_PUSH;
2162 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2163 PAD** const svp = PadlistARRAY(padlist);
2164 AV* const newpad = newAV();
2165 SV** const oldpad = AvARRAY(svp[depth-1]);
2166 I32 ix = AvFILLp((const AV *)svp[1]);
2167 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2168 SV** const names = AvARRAY(svp[0]);
2171 for ( ;ix > 0; ix--) {
2172 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2173 const char sigil = SvPVX_const(names[ix])[0];
2174 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2175 || (SvFLAGS(names[ix]) & SVpad_STATE)
2178 /* outer lexical or anon code */
2179 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2181 else { /* our own lexical */
2184 sv = MUTABLE_SV(newAV());
2185 else if (sigil == '%')
2186 sv = MUTABLE_SV(newHV());
2189 av_store(newpad, ix, sv);
2193 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2194 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2197 /* save temporaries on recursion? */
2198 SV * const sv = newSV(0);
2199 av_store(newpad, ix, sv);
2204 av_store(newpad, 0, MUTABLE_SV(av));
2207 padlist_store(padlist, depth, newpad);
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 padlist_dup
2245 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2251 PERL_ARGS_ASSERT_PADLIST_DUP;
2256 cloneall = param->flags & CLONEf_COPY_STACKS
2257 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2258 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2260 max = cloneall ? PadlistMAX(srcpad) : 1;
2262 Newx(dstpad, 1, PADLIST);
2263 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2264 PadlistMAX(dstpad) = max;
2265 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2269 for (depth = 0; depth <= max; ++depth)
2270 PadlistARRAY(dstpad)[depth] =
2271 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2273 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2274 to build anything other than the first level of pads. */
2275 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2277 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2278 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2279 SV **oldpad = AvARRAY(srcpad1);
2284 PadlistARRAY(dstpad)[0] =
2285 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2286 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2290 av_extend(pad1, ix);
2291 PadlistARRAY(dstpad)[1] = pad1;
2292 pad1a = AvARRAY(pad1);
2297 for ( ;ix > 0; ix--) {
2300 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2301 const char sigil = SvPVX_const(names[ix])[0];
2302 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2303 || (SvFLAGS(names[ix]) & SVpad_STATE)
2306 /* outer lexical or anon code */
2307 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2309 else { /* our own lexical */
2310 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2311 /* This is a work around for how the current
2312 implementation of ?{ } blocks in regexps
2313 interacts with lexicals. */
2314 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2319 sv = MUTABLE_SV(newAV());
2320 else if (sigil == '%')
2321 sv = MUTABLE_SV(newHV());
2329 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2330 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2333 /* save temporaries on recursion? */
2334 SV * const sv = newSV(0);
2337 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2338 FIXTHAT before merging this branch.
2339 (And I know how to) */
2340 if (SvPADMY(oldpad[ix]))
2348 args = newAV(); /* Will be @_ */
2350 pad1a[0] = (SV *)args;
2358 #endif /* USE_ITHREADS */
2361 Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
2365 SSize_t const oldmax = PadlistMAX(padlist);
2367 PERL_ARGS_ASSERT_PADLIST_STORE;
2371 if (key > PadlistMAX(padlist)) {
2372 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2373 (SV ***)&PadlistARRAY(padlist),
2374 (SV ***)&PadlistARRAY(padlist));
2375 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2378 ary = PadlistARRAY(padlist);
2379 SvREFCNT_dec(ary[key]);
2386 * c-indentation-style: bsd
2388 * indent-tabs-mode: nil
2391 * ex: set ts=8 sts=4 sw=4 et: