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 for targets (SVs_PADTMP)
60 and GVs end up having &PL_sv_undef
61 "names", while slots for constants have &PL_sv_no "names" (see
62 pad_alloc()). That &PL_sv_no is used is an implementation detail subject
63 to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
65 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
66 The rest are op targets/GVs/constants which are statically allocated
67 or resolved at compile time. These don't have names by which they
68 can be looked up from Perl code at run time through eval"" the way
69 my/our variables can be. Since they can't be looked up by "name"
70 but only by their index allocated at compile time (which is usually
71 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
73 The SVs in the names AV have their PV being the name of the variable.
74 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
75 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
76 _HIGH). During compilation, these fields may hold the special value
77 PERL_PADSEQ_INTRO to indicate various stages:
79 COP_SEQ_RANGE_LOW _HIGH
80 ----------------- -----
81 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
82 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
83 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
85 For typed lexicals name SV is SVt_PVMG and SvSTASH
86 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
87 SvOURSTASH slot pointing at the stash of the associated global (so that
88 duplicate C<our> declarations in the same package can be detected). SvUVX is
89 sometimes hijacked to store the generation number during compilation.
91 If PADNAME_OUTER (SvFAKE) is set on the
92 name SV, then that slot in the frame AV is
93 a REFCNT'ed reference to a lexical from "outside". In this case,
94 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
95 in scope throughout. Instead xhigh stores some flags containing info about
96 the real lexical (is it declared in an anon, and is it capable of being
97 instantiated multiple times?), and for fake ANONs, xlow contains the index
98 within the parent's pad where the lexical's value is stored, to make
101 If the 'name' is '&' the corresponding entry in the PAD
102 is a CV representing a possible closure.
103 (PADNAME_OUTER and name of '&' is not a
104 meaningful combination currently but could
105 become so if C<my sub foo {}> is implemented.)
107 Note that formats are treated as anon subs, and are cloned each time
108 write is called (if necessary).
110 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
111 and set on scope exit. This allows the
112 'Variable $x is not available' warning
113 to be generated in evals, such as
115 { my $x = 1; sub f { eval '$x'} } f();
117 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
119 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
121 During compilation, this points to the array containing the names part
122 of the pad for the currently-compiling code.
124 =for apidoc AmxU|PAD *|PL_comppad
126 During compilation, this points to the array containing the values
127 part of the pad for the currently-compiling code. (At runtime a CV may
128 have many such value arrays; at compile time just one is constructed.)
129 At runtime, this points to the array containing the currently-relevant
130 values for the pad for the currently-executing code.
132 =for apidoc AmxU|SV **|PL_curpad
134 Points directly to the body of the L</PL_comppad> array.
135 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
142 #define PERL_IN_PAD_C
144 #include "keywords.h"
146 #define COP_SEQ_RANGE_LOW_set(sv,val) \
147 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
148 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
151 #define PARENT_PAD_INDEX_set(sv,val) \
152 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
153 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
154 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
157 This is basically sv_eq_flags() in sv.c, but we avoid the magic
162 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
163 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
164 const char *pv1 = SvPVX_const(sv);
165 STRLEN cur1 = SvCUR(sv);
166 const char *pv2 = pv;
171 svrecode = newSVpvn(pv2, cur2);
172 sv_recode_to_utf8(svrecode, PL_encoding);
173 pv2 = SvPV_const(svrecode, cur2);
176 svrecode = newSVpvn(pv1, cur1);
177 sv_recode_to_utf8(svrecode, PL_encoding);
178 pv1 = SvPV_const(svrecode, cur1);
180 SvREFCNT_dec_NN(svrecode);
182 if (flags & SVf_UTF8)
183 return (bytes_cmp_utf8(
184 (const U8*)pv1, cur1,
185 (const U8*)pv2, cur2) == 0);
187 return (bytes_cmp_utf8(
188 (const U8*)pv2, cur2,
189 (const U8*)pv1, cur1) == 0);
192 return ((SvPVX_const(sv) == pv)
193 || memEQ(SvPVX_const(sv), pv, pvlen));
198 =for apidoc Am|PADLIST *|pad_new|int flags
200 Create a new padlist, updating the global variables for the
201 currently-compiling padlist to point to the new padlist. The following
202 flags can be OR'ed together:
204 padnew_CLONE this pad is for a cloned CV
205 padnew_SAVE save old globals on the save stack
206 padnew_SAVESUB also save extra stuff for start of sub
212 Perl_pad_new(pTHX_ int flags)
218 ASSERT_CURPAD_LEGAL("pad_new");
220 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
221 * vars (based on flags) rather than storing vals + addresses for
222 * each individually. Also see pad_block_start.
223 * XXX DAPM Try to see whether all these conditionals are required
226 /* save existing state, ... */
228 if (flags & padnew_SAVE) {
230 if (! (flags & padnew_CLONE)) {
231 SAVESPTR(PL_comppad_name);
233 SAVEI32(PL_constpadix);
234 SAVEI32(PL_comppad_name_fill);
235 SAVEI32(PL_min_intro_pending);
236 SAVEI32(PL_max_intro_pending);
237 SAVEBOOL(PL_cv_has_eval);
238 if (flags & padnew_SAVESUB) {
239 SAVEBOOL(PL_pad_reset_pending);
243 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
244 * saved - check at some pt that this is okay */
246 /* ... create new pad ... */
248 Newxz(padlist, 1, PADLIST);
251 if (flags & padnew_CLONE) {
252 /* XXX DAPM I dont know why cv_clone needs it
253 * doing differently yet - perhaps this separate branch can be
254 * dispensed with eventually ???
257 AV * const a0 = newAV(); /* will be @_ */
258 av_store(pad, 0, MUTABLE_SV(a0));
261 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
264 av_store(pad, 0, NULL);
266 AvPAD_NAMELIST_on(padname);
267 av_store(padname, 0, &PL_sv_undef);
270 /* Most subroutines never recurse, hence only need 2 entries in the padlist
271 array - names, and depth=1. The default for av_store() is to allocate
272 0..3, and even an explicit call to av_extend() with <3 will be rounded
273 up, so we inline the allocation of the array here. */
275 PadlistMAX(padlist) = 1;
276 PadlistARRAY(padlist) = ary;
280 /* ... then update state variables */
283 PL_curpad = AvARRAY(pad);
285 if (! (flags & padnew_CLONE)) {
286 PL_comppad_name = padname;
287 PL_comppad_name_fill = 0;
288 PL_min_intro_pending = 0;
294 DEBUG_X(PerlIO_printf(Perl_debug_log,
295 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
296 " name=0x%"UVxf" flags=0x%"UVxf"\n",
297 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
298 PTR2UV(padname), (UV)flags
302 return (PADLIST*)padlist;
307 =head1 Embedding Functions
311 Clear out all the active components of a CV. This can happen either
312 by an explicit C<undef &foo>, or by the reference count going to zero.
313 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
314 children can still follow the full lexical scope chain.
320 Perl_cv_undef(pTHX_ CV *cv)
322 PERL_ARGS_ASSERT_CV_UNDEF;
323 cv_undef_flags(cv, 0);
327 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
329 const PADLIST *padlist = CvPADLIST(cv);
330 bool const slabbed = !!CvSLABBED(cv);
332 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
334 DEBUG_X(PerlIO_printf(Perl_debug_log,
335 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
336 PTR2UV(cv), PTR2UV(PL_comppad))
339 if (CvFILE(cv) && CvDYNFILE(cv)) {
340 Safefree(CvFILE(cv));
345 if (!CvISXSUB(cv) && CvROOT(cv)) {
346 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
347 Perl_croak(aTHX_ "Can't undef active subroutine");
350 PAD_SAVE_SETNULLPAD();
352 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
358 else if (slabbed && CvSTART(cv)) {
360 PAD_SAVE_SETNULLPAD();
362 /* discard any leaked ops */
364 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
365 opslab_force_free((OPSLAB *)CvSTART(cv));
371 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
373 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
374 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
375 if (!(flags & CV_UNDEF_KEEP_NAME)) {
377 CvNAME_HEK_set(cv, NULL);
380 else CvGV_set(cv, NULL);
383 /* This statement and the subsequence if block was pad_undef(). */
384 pad_peg("pad_undef");
389 /* Free the padlist associated with a CV.
390 If parts of it happen to be current, we null the relevant PL_*pad*
391 global vars so that we don't have any dangling references left.
392 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
393 subs to the outer of this cv. */
395 DEBUG_X(PerlIO_printf(Perl_debug_log,
396 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
397 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
400 /* detach any '&' anon children in the pad; if afterwards they
401 * are still live, fix up their CvOUTSIDEs to point to our outside,
403 /* XXX DAPM for efficiency, we should only do this if we know we have
404 * children, or integrate this loop with general cleanup */
406 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
407 CV * const outercv = CvOUTSIDE(cv);
408 const U32 seq = CvOUTSIDE_SEQ(cv);
409 PAD * const comppad_name = PadlistARRAY(padlist)[0];
410 SV ** const namepad = AvARRAY(comppad_name);
411 PAD * const comppad = PadlistARRAY(padlist)[1];
412 SV ** const curpad = AvARRAY(comppad);
413 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
414 SV * const namesv = namepad[ix];
415 if (namesv && namesv != &PL_sv_undef
416 && *SvPVX_const(namesv) == '&')
418 CV * const innercv = MUTABLE_CV(curpad[ix]);
419 U32 inner_rc = SvREFCNT(innercv);
421 assert(SvTYPE(innercv) != SVt_PVFM);
423 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
425 SvREFCNT_dec_NN(innercv);
429 /* in use, not just a prototype */
430 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
431 assert(CvWEAKOUTSIDE(innercv));
432 /* don't relink to grandfather if he's being freed */
433 if (outercv && SvREFCNT(outercv)) {
434 CvWEAKOUTSIDE_off(innercv);
435 CvOUTSIDE(innercv) = outercv;
436 CvOUTSIDE_SEQ(innercv) = seq;
437 SvREFCNT_inc_simple_void_NN(outercv);
440 CvOUTSIDE(innercv) = NULL;
447 ix = PadlistMAX(padlist);
449 PAD * const sv = PadlistARRAY(padlist)[ix--];
451 if (sv == PL_comppad) {
459 PAD * const sv = PadlistARRAY(padlist)[0];
460 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
461 PL_comppad_name = NULL;
464 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
466 CvPADLIST(cv) = NULL;
470 /* remove CvOUTSIDE unless this is an undef rather than a free */
471 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
472 if (!CvWEAKOUTSIDE(cv))
473 SvREFCNT_dec(CvOUTSIDE(cv));
474 CvOUTSIDE(cv) = NULL;
477 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
480 if (CvISXSUB(cv) && CvXSUB(cv)) {
483 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
484 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
485 * LEXICAL, which are used to determine the sub's name. */
486 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
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);
508 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
510 if (!slabbed) return;
514 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
515 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
517 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
521 #ifdef PERL_DEBUG_READONLY_OPS
522 const size_t refcnt = slab->opslab_refcnt;
524 OpslabREFCNT_dec(slab);
525 #ifdef PERL_DEBUG_READONLY_OPS
526 if (refcnt > 1) Slab_to_ro(slab);
532 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
534 Allocates a place in the currently-compiling
535 pad (via L<perlapi/pad_alloc>) and
536 then stores a name for that entry. I<namesv> is adopted and becomes the
537 name entry; it must already contain the name string and be sufficiently
538 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
539 added to I<namesv>. None of the other
540 processing of L<perlapi/pad_add_name_pvn>
541 is done. Returns the offset of the allocated pad slot.
547 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
549 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
551 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
553 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
556 assert(SvTYPE(namesv) == SVt_PVMG);
557 SvPAD_TYPED_on(namesv);
558 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
561 SvPAD_OUR_on(namesv);
562 SvOURSTASH_set(namesv, ourstash);
563 SvREFCNT_inc_simple_void_NN(ourstash);
565 else if (flags & padadd_STATE) {
566 SvPAD_STATE_on(namesv);
569 av_store(PL_comppad_name, offset, namesv);
570 PadnamelistMAXNAMED(PL_comppad_name) = offset;
575 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
577 Allocates a place in the currently-compiling pad for a named lexical
578 variable. Stores the name and other metadata in the name part of the
579 pad, and makes preparations to manage the variable's lexical scoping.
580 Returns the offset of the allocated pad slot.
582 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
583 If I<typestash> is non-null, the name is for a typed lexical, and this
584 identifies the type. If I<ourstash> is non-null, it's a lexical reference
585 to a package variable, and this identifies the package. The following
586 flags can be OR'ed together:
588 padadd_OUR redundantly specifies if it's a package var
589 padadd_STATE variable will retain value persistently
590 padadd_NO_DUP_CHECK skip check for lexical shadowing
596 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
597 U32 flags, HV *typestash, HV *ourstash)
603 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
605 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
606 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
609 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
611 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
612 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
615 sv_setpvn(namesv, namepv, namelen);
618 flags |= padadd_UTF8_NAME;
622 flags &= ~padadd_UTF8_NAME;
624 if ((flags & padadd_NO_DUP_CHECK) == 0) {
626 SAVEFREESV(namesv); /* in case of fatal warnings */
627 /* check for duplicate declaration */
628 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
629 SvREFCNT_inc_simple_void_NN(namesv);
633 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
635 /* not yet introduced */
636 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
637 COP_SEQ_RANGE_HIGH_set(namesv, 0);
639 if (!PL_min_intro_pending)
640 PL_min_intro_pending = offset;
641 PL_max_intro_pending = offset;
642 /* if it's not a simple scalar, replace with an AV or HV */
643 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
644 assert(SvREFCNT(PL_curpad[offset]) == 1);
645 if (namelen != 0 && *namepv == '@')
646 sv_upgrade(PL_curpad[offset], SVt_PVAV);
647 else if (namelen != 0 && *namepv == '%')
648 sv_upgrade(PL_curpad[offset], SVt_PVHV);
649 else if (namelen != 0 && *namepv == '&')
650 sv_upgrade(PL_curpad[offset], SVt_PVCV);
651 assert(SvPADMY(PL_curpad[offset]));
652 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
653 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
654 (long)offset, SvPVX(namesv),
655 PTR2UV(PL_curpad[offset])));
661 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
663 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
664 instead of a string/length pair.
670 Perl_pad_add_name_pv(pTHX_ const char *name,
671 const U32 flags, HV *typestash, HV *ourstash)
673 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
674 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
678 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
680 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
681 of an SV instead of a string/length pair.
687 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
691 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
692 namepv = SvPV(name, namelen);
694 flags |= padadd_UTF8_NAME;
695 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
699 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
701 Allocates a place in the currently-compiling pad,
702 returning the offset of the allocated pad slot.
703 No name is initially attached to the pad slot.
704 I<tmptype> is a set of flags indicating the kind of pad entry required,
705 which will be set in the value SV for the allocated pad entry:
707 SVs_PADMY named lexical variable ("my", "our", "state")
708 SVs_PADTMP unnamed temporary store
709 SVf_READONLY constant shared between recursion levels
711 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
712 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
713 does not cause the SV in the pad slot to be marked read-only, but simply
714 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
715 least should be treated as such.
717 I<optype> should be an opcode indicating the type of operation that the
718 pad entry is to support. This doesn't affect operational semantics,
719 but is used for debugging.
724 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
725 * or at least rationalise ??? */
728 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
733 PERL_UNUSED_ARG(optype);
734 ASSERT_CURPAD_ACTIVE("pad_alloc");
736 if (AvARRAY(PL_comppad) != PL_curpad)
737 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
738 AvARRAY(PL_comppad), PL_curpad);
739 if (PL_pad_reset_pending)
741 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
742 /* For a my, simply push a null SV onto the end of PL_comppad. */
743 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
744 retval = AvFILLp(PL_comppad);
747 /* For a tmp, scan the pad from PL_padix upwards
748 * for a slot which has no name and no active value.
749 * For a constant, likewise, but use PL_constpadix.
751 SV * const * const names = AvARRAY(PL_comppad_name);
752 const SSize_t names_fill = AvFILLp(PL_comppad_name);
753 const bool konst = cBOOL(tmptype & SVf_READONLY);
754 retval = konst ? PL_constpadix : PL_padix;
757 * Entries that close over unavailable variables
758 * in outer subs contain values not marked PADMY.
759 * Thus we must skip, not just pad values that are
760 * marked as current pad values, but also those with names.
761 * If pad_reset is enabled, ‘current’ means different
762 * things depending on whether we are allocating a con-
763 * stant or a target. For a target, things marked PADTMP
764 * can be reused; not so for constants.
766 if (++retval <= names_fill &&
767 (sv = names[retval]) && sv != &PL_sv_undef)
769 sv = *av_fetch(PL_comppad, retval, TRUE);
772 (konst ? SVs_PADTMP : 0))
780 av_store(PL_comppad_name, retval, &PL_sv_no);
781 tmptype &= ~SVf_READONLY;
782 tmptype |= SVs_PADTMP;
784 *(konst ? &PL_constpadix : &PL_padix) = retval;
786 SvFLAGS(sv) |= tmptype;
787 PL_curpad = AvARRAY(PL_comppad);
789 DEBUG_X(PerlIO_printf(Perl_debug_log,
790 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
791 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
792 PL_op_name[optype]));
793 #ifdef DEBUG_LEAKING_SCALARS
794 sv->sv_debug_optype = optype;
795 sv->sv_debug_inpad = 1;
797 return (PADOFFSET)retval;
801 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
803 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
804 for an anonymous function that is lexically scoped inside the
805 currently-compiling function.
806 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
807 to the outer scope is weakened to avoid a reference loop.
809 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
811 I<optype> should be an opcode indicating the type of operation that the
812 pad entry is to support. This doesn't affect operational semantics,
813 but is used for debugging.
819 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
822 SV* const name = newSV_type(SVt_PVNV);
824 PERL_ARGS_ASSERT_PAD_ADD_ANON;
827 sv_setpvs(name, "&");
828 /* These two aren't used; just make sure they're not equal to
829 * PERL_PADSEQ_INTRO */
830 COP_SEQ_RANGE_LOW_set(name, 0);
831 COP_SEQ_RANGE_HIGH_set(name, 0);
832 ix = pad_alloc(optype, SVs_PADMY);
833 av_store(PL_comppad_name, ix, name);
834 /* XXX DAPM use PL_curpad[] ? */
835 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
836 av_store(PL_comppad, ix, (SV*)func);
838 SV *rv = newRV_noinc((SV *)func);
840 assert (SvTYPE(func) == SVt_PVFM);
841 av_store(PL_comppad, ix, rv);
844 /* to avoid ref loops, we never have parent + child referencing each
845 * other simultaneously */
846 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
847 assert(!CvWEAKOUTSIDE(func));
848 CvWEAKOUTSIDE_on(func);
849 SvREFCNT_dec_NN(CvOUTSIDE(func));
855 =for apidoc pad_check_dup
857 Check for duplicate declarations: report any of:
859 * a my in the current scope with the same name;
860 * an our (anywhere in the pad) with the same name and the
861 same stash as C<ourstash>
863 C<is_our> indicates that the name to check is an 'our' declaration.
869 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
873 const U32 is_our = flags & padadd_OUR;
875 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
877 ASSERT_CURPAD_ACTIVE("pad_check_dup");
879 assert((flags & ~padadd_OUR) == 0);
881 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
882 return; /* nothing to check */
884 svp = AvARRAY(PL_comppad_name);
885 top = AvFILLp(PL_comppad_name);
886 /* check the current scope */
887 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
889 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
890 SV * const sv = svp[off];
894 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
895 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
898 if (is_our && (SvPAD_OUR(sv)))
899 break; /* "our" masking "our" */
900 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
901 Perl_warner(aTHX_ packWARN(WARN_MISC),
902 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
903 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
904 *SvPVX(sv) == '&' ? "subroutine" : "variable",
906 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
907 ? "scope" : "statement"));
912 /* check the rest of the pad */
915 SV * const sv = svp[off];
919 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
920 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
921 && SvOURSTASH(sv) == ourstash
924 Perl_warner(aTHX_ packWARN(WARN_MISC),
925 "\"our\" variable %"SVf" redeclared", SVfARG(sv));
926 if ((I32)off <= PL_comppad_name_floor)
927 Perl_warner(aTHX_ packWARN(WARN_MISC),
928 "\t(Did you mean \"local\" instead of \"our\"?)\n");
938 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
940 Given the name of a lexical variable, find its position in the
941 currently-compiling pad.
942 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
943 I<flags> is reserved and must be zero.
944 If it is not in the current pad but appears in the pad of any lexically
945 enclosing scope, then a pseudo-entry for it is added in the current pad.
946 Returns the offset in the current pad,
947 or C<NOT_IN_PAD> if no such lexical is in scope.
953 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
961 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
963 pad_peg("pad_findmy_pvn");
965 if (flags & ~padadd_UTF8_NAME)
966 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
969 if (flags & padadd_UTF8_NAME) {
971 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
974 flags |= padadd_UTF8_NAME;
976 flags &= ~padadd_UTF8_NAME;
979 offset = pad_findlex(namepv, namelen, flags,
980 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
981 if ((PADOFFSET)offset != NOT_IN_PAD)
984 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
986 if (*namepv == '&') return NOT_IN_PAD;
988 /* look for an our that's being introduced; this allows
989 * our $foo = 0 unless defined $foo;
990 * to not give a warning. (Yes, this is a hack) */
992 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
993 name_svp = AvARRAY(nameav);
994 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
995 const SV * const namesv = name_svp[offset];
996 if (namesv && PadnameLEN(namesv) == namelen
998 && (SvPAD_OUR(namesv))
999 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1000 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
1001 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1009 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1011 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1012 instead of a string/length pair.
1018 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1020 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1021 return pad_findmy_pvn(name, strlen(name), flags);
1025 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1027 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1028 of an SV instead of a string/length pair.
1034 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1038 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1039 namepv = SvPV(name, namelen);
1041 flags |= padadd_UTF8_NAME;
1042 return pad_findmy_pvn(namepv, namelen, flags);
1046 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1048 Find the position of the lexical C<$_> in the pad of the
1049 currently-executing function. Returns the offset in the current pad,
1050 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1051 the global one should be used instead).
1052 L</find_rundefsv> is likely to be more convenient.
1058 Perl_find_rundefsvoffset(pTHX)
1062 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1063 NULL, &out_sv, &out_flags);
1067 =for apidoc Am|SV *|find_rundefsv
1069 Find and return the variable that is named C<$_> in the lexical scope
1070 of the currently-executing function. This may be a lexical C<$_>,
1071 or will otherwise be the global one.
1077 Perl_find_rundefsv(pTHX)
1083 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1084 NULL, &namesv, &flags);
1086 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1093 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1099 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1101 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1102 NULL, &namesv, &flags);
1104 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1107 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1111 =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
1113 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1114 in the inner pads if it's found in an outer one.
1116 Returns the offset in the bottom pad of the lex or the fake lex.
1117 cv is the CV in which to start the search, and seq is the current cop_seq
1118 to match against. If warn is true, print appropriate warnings. The out_*
1119 vars return values, and so are pointers to where the returned values
1120 should be stored. out_capture, if non-null, requests that the innermost
1121 instance of the lexical is captured; out_name_sv is set to the innermost
1122 matched namesv or fake namesv; out_flags returns the flags normally
1123 associated with the IVX field of a fake namesv.
1125 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1126 then comes back down, adding fake entries
1127 as it goes. It has to be this way
1128 because fake namesvs in anon protoypes have to store in xlow the index into
1134 /* the CV has finished being compiled. This is not a sufficient test for
1135 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1136 #define CvCOMPILED(cv) CvROOT(cv)
1138 /* the CV does late binding of its lexicals */
1139 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1142 S_unavailable(pTHX_ SV *namesv)
1144 /* diag_listed_as: Variable "%s" is not available */
1145 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1146 "%se \"%"SVf"\" is not available",
1147 *SvPVX_const(namesv) == '&'
1154 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1155 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1157 I32 offset, new_offset;
1160 const PADLIST * const padlist = CvPADLIST(cv);
1161 const bool staleok = !!(flags & padadd_STALEOK);
1163 PERL_ARGS_ASSERT_PAD_FINDLEX;
1165 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1166 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1168 flags &= ~ padadd_STALEOK; /* one-shot flag */
1172 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1173 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1174 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1175 out_capture ? " capturing" : "" ));
1177 /* first, search this pad */
1179 if (padlist) { /* not an undef CV */
1180 I32 fake_offset = 0;
1181 const AV * const nameav = PadlistARRAY(padlist)[0];
1182 SV * const * const name_svp = AvARRAY(nameav);
1184 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1185 const SV * const namesv = name_svp[offset];
1186 if (namesv && PadnameLEN(namesv) == namelen
1187 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1188 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1190 if (SvFAKE(namesv)) {
1191 fake_offset = offset; /* in case we don't find a real one */
1194 /* is seq within the range _LOW to _HIGH ?
1195 * This is complicated by the fact that PL_cop_seqmax
1196 * may have wrapped around at some point */
1197 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1198 continue; /* not yet introduced */
1200 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1201 /* in compiling scope */
1203 (seq > COP_SEQ_RANGE_LOW(namesv))
1204 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1205 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1210 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1212 ( seq > COP_SEQ_RANGE_LOW(namesv)
1213 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1215 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1216 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1222 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1223 if (offset > 0) { /* not fake */
1225 *out_name_sv = name_svp[offset]; /* return the namesv */
1227 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1228 * instances. For now, we just test !CvUNIQUE(cv), but
1229 * ideally, we should detect my's declared within loops
1230 * etc - this would allow a wider range of 'not stayed
1231 * shared' warnings. We also treated already-compiled
1232 * lexes as not multi as viewed from evals. */
1234 *out_flags = CvANON(cv) ?
1236 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1237 ? PAD_FAKELEX_MULTI : 0;
1239 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1240 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1241 PTR2UV(cv), (long)offset,
1242 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1243 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1245 else { /* fake match */
1246 offset = fake_offset;
1247 *out_name_sv = name_svp[offset]; /* return the namesv */
1248 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1249 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1250 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1251 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1252 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1256 /* return the lex? */
1261 if (SvPAD_OUR(*out_name_sv)) {
1262 *out_capture = NULL;
1266 /* trying to capture from an anon prototype? */
1268 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1269 : *out_flags & PAD_FAKELEX_ANON)
1273 newSVpvn_flags(namepv, namelen,
1275 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1277 *out_capture = NULL;
1283 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1284 && !SvPAD_STATE(name_svp[offset])
1285 && warn && ckWARN(WARN_CLOSURE)) {
1287 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1288 "Variable \"%"SVf"\" will not stay shared",
1289 SVfARG(newSVpvn_flags(namepv, namelen,
1291 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1294 if (fake_offset && CvANON(cv)
1295 && CvCLONE(cv) &&!CvCLONED(cv))
1298 /* not yet caught - look further up */
1299 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1300 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1303 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1305 newwarn, out_capture, out_name_sv, out_flags);
1310 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1311 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1312 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1313 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1314 PTR2UV(cv), PTR2UV(*out_capture)));
1316 if (SvPADSTALE(*out_capture)
1317 && (!CvDEPTH(cv) || !staleok)
1318 && !SvPAD_STATE(name_svp[offset]))
1321 newSVpvn_flags(namepv, namelen,
1323 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1324 *out_capture = NULL;
1327 if (!*out_capture) {
1328 if (namelen != 0 && *namepv == '@')
1329 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1330 else if (namelen != 0 && *namepv == '%')
1331 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1332 else if (namelen != 0 && *namepv == '&')
1333 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1335 *out_capture = sv_newmortal();
1343 /* it's not in this pad - try above */
1348 /* out_capture non-null means caller wants us to capture lex; in
1349 * addition we capture ourselves unless it's an ANON/format */
1350 new_capturep = out_capture ? out_capture :
1351 CvLATE(cv) ? NULL : &new_capture;
1353 offset = pad_findlex(namepv, namelen,
1354 flags | padadd_STALEOK*(new_capturep == &new_capture),
1355 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1356 new_capturep, out_name_sv, out_flags);
1357 if ((PADOFFSET)offset == NOT_IN_PAD)
1360 /* found in an outer CV. Add appropriate fake entry to this pad */
1362 /* don't add new fake entries (via eval) to CVs that we have already
1363 * finished compiling, or to undef CVs */
1364 if (CvCOMPILED(cv) || !padlist)
1365 return 0; /* this dummy (and invalid) value isnt used by the caller */
1368 /* This relies on sv_setsv_flags() upgrading the destination to the same
1369 type as the source, independent of the flags set, and on it being
1370 "good" and only copying flag bits and pointers that it understands.
1372 SV *new_namesv = newSVsv(*out_name_sv);
1373 AV * const ocomppad_name = PL_comppad_name;
1374 PAD * const ocomppad = PL_comppad;
1375 PL_comppad_name = PadlistARRAY(padlist)[0];
1376 PL_comppad = PadlistARRAY(padlist)[1];
1377 PL_curpad = AvARRAY(PL_comppad);
1380 = pad_alloc_name(new_namesv,
1381 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1382 SvPAD_TYPED(*out_name_sv)
1383 ? SvSTASH(*out_name_sv) : NULL,
1384 SvOURSTASH(*out_name_sv)
1387 SvFAKE_on(new_namesv);
1388 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1389 "Pad addname: %ld \"%.*s\" FAKE\n",
1391 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1392 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1394 PARENT_PAD_INDEX_set(new_namesv, 0);
1395 if (SvPAD_OUR(new_namesv)) {
1396 NOOP; /* do nothing */
1398 else if (CvLATE(cv)) {
1399 /* delayed creation - just note the offset within parent pad */
1400 PARENT_PAD_INDEX_set(new_namesv, offset);
1404 /* immediate creation - capture outer value right now */
1405 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1406 /* But also note the offset, as newMYSUB needs it */
1407 PARENT_PAD_INDEX_set(new_namesv, offset);
1408 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1409 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1410 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1412 *out_name_sv = new_namesv;
1413 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1415 PL_comppad_name = ocomppad_name;
1416 PL_comppad = ocomppad;
1417 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1425 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1427 Get the value at offset I<po> in the current (compiling or executing) pad.
1428 Use macro PAD_SV instead of calling this function directly.
1434 Perl_pad_sv(pTHX_ PADOFFSET po)
1436 ASSERT_CURPAD_ACTIVE("pad_sv");
1439 Perl_croak(aTHX_ "panic: pad_sv po");
1440 DEBUG_X(PerlIO_printf(Perl_debug_log,
1441 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1442 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1444 return PL_curpad[po];
1448 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1450 Set the value at offset I<po> in the current (compiling or executing) pad.
1451 Use the macro PAD_SETSV() rather than calling this function directly.
1457 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1459 PERL_ARGS_ASSERT_PAD_SETSV;
1461 ASSERT_CURPAD_ACTIVE("pad_setsv");
1463 DEBUG_X(PerlIO_printf(Perl_debug_log,
1464 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1465 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1470 #endif /* DEBUGGING */
1473 =for apidoc m|void|pad_block_start|int full
1475 Update the pad compilation state variables on entry to a new block.
1480 /* XXX DAPM perhaps:
1481 * - integrate this in general state-saving routine ???
1482 * - combine with the state-saving going on in pad_new ???
1483 * - introduce a new SAVE type that does all this in one go ?
1487 Perl_pad_block_start(pTHX_ int full)
1489 ASSERT_CURPAD_ACTIVE("pad_block_start");
1490 SAVEI32(PL_comppad_name_floor);
1491 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1493 PL_comppad_name_fill = PL_comppad_name_floor;
1494 if (PL_comppad_name_floor < 0)
1495 PL_comppad_name_floor = 0;
1496 SAVEI32(PL_min_intro_pending);
1497 SAVEI32(PL_max_intro_pending);
1498 PL_min_intro_pending = 0;
1499 SAVEI32(PL_comppad_name_fill);
1500 SAVEI32(PL_padix_floor);
1501 /* PL_padix_floor is what PL_padix is reset to at the start of each
1502 statement, by pad_reset(). We set it when entering a new scope
1503 to keep things like this working:
1504 print "$foo$bar", do { this(); that() . "foo" };
1505 We must not let "$foo$bar" and the later concatenation share the
1507 PL_padix_floor = PL_padix;
1508 PL_pad_reset_pending = FALSE;
1512 =for apidoc m|U32|intro_my
1514 "Introduce" my variables to visible status. This is called during parsing
1515 at the end of each statement to make lexical variables visible to
1516 subsequent statements.
1528 ASSERT_CURPAD_ACTIVE("intro_my");
1529 if (! PL_min_intro_pending)
1530 return PL_cop_seqmax;
1532 svp = AvARRAY(PL_comppad_name);
1533 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1534 SV * const sv = svp[i];
1536 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1537 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1539 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1540 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1541 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1542 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1543 (long)i, SvPVX_const(sv),
1544 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1545 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1549 seq = PL_cop_seqmax;
1551 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1553 PL_min_intro_pending = 0;
1554 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1555 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1556 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1562 =for apidoc m|void|pad_leavemy
1564 Cleanup at end of scope during compilation: set the max seq number for
1565 lexicals in this scope and warn of any lexicals that never got introduced.
1571 Perl_pad_leavemy(pTHX)
1575 SV * const * const svp = AvARRAY(PL_comppad_name);
1577 PL_pad_reset_pending = FALSE;
1579 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1580 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1581 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1582 const SV * const sv = svp[off];
1583 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1584 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1585 "%"SVf" never introduced",
1589 /* "Deintroduce" my variables that are leaving with this scope. */
1590 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1591 SV * const sv = svp[off];
1592 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1593 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1595 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1596 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1597 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1598 (long)off, SvPVX_const(sv),
1599 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1600 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1602 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1603 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1604 OP *kid = newOP(OP_INTROCV, 0);
1606 o = op_prepend_elem(OP_LINESEQ, kid, o);
1611 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1613 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1614 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1619 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1621 Abandon the tmp in the current pad at offset po and replace with a
1628 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1630 ASSERT_CURPAD_LEGAL("pad_swipe");
1633 if (AvARRAY(PL_comppad) != PL_curpad)
1634 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1635 AvARRAY(PL_comppad), PL_curpad);
1636 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1637 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1638 (long)po, (long)AvFILLp(PL_comppad));
1640 DEBUG_X(PerlIO_printf(Perl_debug_log,
1641 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1642 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1645 SvREFCNT_dec(PL_curpad[po]);
1648 /* if pad tmps aren't shared between ops, then there's no need to
1649 * create a new tmp when an existing op is freed */
1650 #ifdef USE_PAD_RESET
1651 PL_curpad[po] = newSV(0);
1652 SvPADTMP_on(PL_curpad[po]);
1654 PL_curpad[po] = NULL;
1656 if (PadnamelistMAX(PL_comppad_name) != -1
1657 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1658 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1659 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1661 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1663 /* Use PL_constpadix here, not PL_padix. The latter may have been
1664 reset by pad_reset. We don’t want pad_alloc to have to scan the
1665 whole pad when allocating a constant. */
1666 if ((I32)po < PL_constpadix)
1667 PL_constpadix = po - 1;
1671 =for apidoc m|void|pad_reset
1673 Mark all the current temporaries for reuse
1678 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1679 * between OPs from different statements. During compilation, at the start
1680 * of each statement pad_reset resets PL_padix back to its previous value.
1681 * When allocating a target, pad_alloc begins its scan through the pad at
1686 #ifdef USE_PAD_RESET
1687 if (AvARRAY(PL_comppad) != PL_curpad)
1688 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1689 AvARRAY(PL_comppad), PL_curpad);
1691 DEBUG_X(PerlIO_printf(Perl_debug_log,
1692 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1693 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1694 (long)PL_padix, (long)PL_padix_floor
1698 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1699 PL_padix = PL_padix_floor;
1702 PL_pad_reset_pending = FALSE;
1706 =for apidoc Amx|void|pad_tidy|padtidy_type type
1708 Tidy up a pad at the end of compilation of the code to which it belongs.
1709 Jobs performed here are: remove most stuff from the pads of anonsub
1710 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1711 the kind of subroutine:
1713 padtidy_SUB ordinary subroutine
1714 padtidy_SUBCLONE prototype for lexical closure
1715 padtidy_FORMAT format
1720 /* XXX DAPM surely most of this stuff should be done properly
1721 * at the right time beforehand, rather than going around afterwards
1722 * cleaning up our mistakes ???
1726 Perl_pad_tidy(pTHX_ padtidy_type type)
1730 ASSERT_CURPAD_ACTIVE("pad_tidy");
1732 /* If this CV has had any 'eval-capable' ops planted in it:
1733 * i.e. it contains any of:
1737 * * use re 'eval'; /$var/
1740 * Then any anon prototypes in the chain of CVs should be marked as
1741 * cloneable, so that for example the eval's CV in
1745 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1746 * potentially have an eval executed within it.
1749 if (PL_cv_has_eval || PL_perldb) {
1751 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1752 if (cv != PL_compcv && CvCOMPILED(cv))
1753 break; /* no need to mark already-compiled code */
1755 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1756 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1763 /* extend namepad to match curpad */
1764 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1765 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1767 if (type == padtidy_SUBCLONE) {
1768 SV ** const namep = AvARRAY(PL_comppad_name);
1771 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1773 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1776 * The only things that a clonable function needs in its
1777 * pad are anonymous subs, constants and GVs.
1778 * The rest are created anew during cloning.
1780 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1783 if (!(PadnamePV(namesv) &&
1784 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1786 SvREFCNT_dec(PL_curpad[ix]);
1787 PL_curpad[ix] = NULL;
1791 else if (type == padtidy_SUB) {
1792 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1793 AV * const av = newAV(); /* Will be @_ */
1794 av_store(PL_comppad, 0, MUTABLE_SV(av));
1798 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1799 SV ** const namep = AvARRAY(PL_comppad_name);
1801 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1802 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1803 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1805 if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
1806 /* This is a work around for how the current implementation of
1807 ?{ } blocks in regexps interacts with lexicals.
1809 One of our lexicals.
1810 Can't do this on all lexicals, otherwise sub baz() won't
1819 because completion of compiling &bar calling pad_tidy()
1820 would cause (top level) $foo to be marked as stale, and
1821 "no longer available". */
1822 SvPADSTALE_on(PL_curpad[ix]);
1826 PL_curpad = AvARRAY(PL_comppad);
1830 =for apidoc m|void|pad_free|PADOFFSET po
1832 Free the SV at offset po in the current pad.
1837 /* XXX DAPM integrate with pad_swipe ???? */
1839 Perl_pad_free(pTHX_ PADOFFSET po)
1841 #ifndef USE_PAD_RESET
1844 ASSERT_CURPAD_LEGAL("pad_free");
1847 if (AvARRAY(PL_comppad) != PL_curpad)
1848 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1849 AvARRAY(PL_comppad), PL_curpad);
1851 Perl_croak(aTHX_ "panic: pad_free po");
1853 DEBUG_X(PerlIO_printf(Perl_debug_log,
1854 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1855 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1858 #ifndef USE_PAD_RESET
1860 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1861 SvFLAGS(sv) &= ~SVs_PADTMP;
1863 if ((I32)po < PL_padix)
1869 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1871 Dump the contents of a padlist
1877 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1885 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1890 pad_name = *PadlistARRAY(padlist);
1891 pad = PadlistARRAY(padlist)[1];
1892 pname = AvARRAY(pad_name);
1893 ppad = AvARRAY(pad);
1894 Perl_dump_indent(aTHX_ level, file,
1895 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1896 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1899 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1900 const SV *namesv = pname[ix];
1901 if (namesv && !PadnameLEN(namesv)) {
1906 Perl_dump_indent(aTHX_ level+1, file,
1907 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1910 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1911 SvPVX_const(namesv),
1912 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1913 (unsigned long)PARENT_PAD_INDEX(namesv)
1917 Perl_dump_indent(aTHX_ level+1, file,
1918 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1921 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1922 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1923 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1928 Perl_dump_indent(aTHX_ level+1, file,
1929 "%2d. 0x%"UVxf"<%lu>\n",
1932 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1941 =for apidoc m|void|cv_dump|CV *cv|const char *title
1943 dump the contents of a CV
1949 S_cv_dump(pTHX_ const CV *cv, const char *title)
1951 const CV * const outside = CvOUTSIDE(cv);
1952 PADLIST* const padlist = CvPADLIST(cv);
1954 PERL_ARGS_ASSERT_CV_DUMP;
1956 PerlIO_printf(Perl_debug_log,
1957 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1960 (CvANON(cv) ? "ANON"
1961 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1962 : (cv == PL_main_cv) ? "MAIN"
1963 : CvUNIQUE(cv) ? "UNIQUE"
1964 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1967 : CvANON(outside) ? "ANON"
1968 : (outside == PL_main_cv) ? "MAIN"
1969 : CvUNIQUE(outside) ? "UNIQUE"
1970 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1972 PerlIO_printf(Perl_debug_log,
1973 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1974 do_dump_pad(1, Perl_debug_log, padlist, 1);
1977 #endif /* DEBUGGING */
1980 =for apidoc Am|CV *|cv_clone|CV *proto
1982 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1983 of the function: its code, pad structure, and other attributes.
1984 The prototype is combined with a capture of outer lexicals to which the
1985 code refers, which are taken from the currently-executing instance of
1986 the immediately surrounding code.
1991 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1994 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1997 PADLIST* const protopadlist = CvPADLIST(proto);
1998 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1999 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2000 SV** const pname = AvARRAY(protopad_name);
2001 SV** const ppad = AvARRAY(protopad);
2002 const I32 fname = AvFILLp(protopad_name);
2003 const I32 fpad = AvFILLp(protopad);
2006 bool subclones = FALSE;
2008 assert(!CvUNIQUE(proto));
2010 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2011 * reliable. The currently-running sub is always the one we need to
2013 * For my subs, the currently-running sub may not be the one we want.
2014 * We have to check whether it is a clone of CvOUTSIDE.
2015 * Note that in general for formats, CvOUTSIDE != find_runcv.
2016 * Since formats may be nested inside closures, CvOUTSIDE may point
2017 * to a prototype; we instead want the cloned parent who called us.
2021 if (CvWEAKOUTSIDE(proto))
2022 outside = find_runcv(NULL);
2024 outside = CvOUTSIDE(proto);
2025 if ((CvCLONE(outside) && ! CvCLONED(outside))
2026 || !CvPADLIST(outside)
2027 || PadlistNAMES(CvPADLIST(outside))
2028 != protopadlist->xpadl_outid) {
2029 outside = find_runcv_where(
2030 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2032 /* outside could be null */
2036 depth = outside ? CvDEPTH(outside) : 0;
2041 SAVESPTR(PL_compcv);
2043 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2046 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2048 SAVESPTR(PL_comppad_name);
2049 PL_comppad_name = protopad_name;
2050 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2052 av_fill(PL_comppad, fpad);
2054 PL_curpad = AvARRAY(PL_comppad);
2056 outpad = outside && CvPADLIST(outside)
2057 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2060 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2062 for (ix = fpad; ix > 0; ix--) {
2063 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2065 if (namesv && PadnameLEN(namesv)) { /* lexical */
2066 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2070 if (SvFAKE(namesv)) { /* lexical from outside? */
2071 /* formats may have an inactive, or even undefined, parent;
2072 but state vars are always available. */
2073 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2074 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2075 && (!outside || !CvDEPTH(outside))) ) {
2076 S_unavailable(aTHX_ namesv);
2080 SvREFCNT_inc_simple_void_NN(sv);
2083 const char sigil = SvPVX_const(namesv)[0];
2085 /* If there are state subs, we need to clone them, too.
2086 But they may need to close over variables we have
2087 not cloned yet. So we will have to do a second
2088 pass. Furthermore, there may be state subs clos-
2089 ing over other state subs’ entries, so we have
2090 to put a stub here and then clone into it on the
2092 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2093 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2095 sv = newSV_type(SVt_PVCV);
2098 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2101 /* Just provide a stub, but name it. It will be
2102 upgrade to the real thing on scope entry. */
2105 PERL_HASH(hash, SvPVX_const(namesv)+1,
2107 sv = newSV_type(SVt_PVCV);
2110 share_hek(SvPVX_const(namesv)+1,
2112 * (SvUTF8(namesv) ? -1 : 1),
2117 else sv = SvREFCNT_inc(ppad[ix]);
2118 else if (sigil == '@')
2119 sv = MUTABLE_SV(newAV());
2120 else if (sigil == '%')
2121 sv = MUTABLE_SV(newHV());
2124 /* reset the 'assign only once' flag on each state var */
2125 if (sigil != '&' && SvPAD_STATE(namesv))
2130 else if (namesv && PadnamePV(namesv)) {
2131 sv = SvREFCNT_inc_NN(ppad[ix]);
2141 for (ix = fpad; ix > 0; ix--) {
2142 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2143 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2144 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2145 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2148 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2153 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2158 const bool newcv = !cv;
2160 assert(!CvUNIQUE(proto));
2162 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2163 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2167 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2170 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2171 else CvGV_set(cv,CvGV(proto));
2172 CvSTASH_set(cv, CvSTASH(proto));
2174 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2176 CvSTART(cv) = CvSTART(proto);
2177 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2180 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2182 SvUTF8_on(MUTABLE_SV(cv));
2185 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2187 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2190 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2191 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2192 cv_dump(proto, "Proto");
2197 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2198 * The prototype was marked as a candiate for const-ization,
2199 * so try to grab the current const value, and if successful,
2200 * turn into a const sub:
2202 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2204 SvREFCNT_dec_NN(cv);
2205 /* For this calling case, op_const_sv returns a *copy*, which we
2206 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2207 Need to fix how lib/constant.pm works to eliminate this. */
2208 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2219 Perl_cv_clone(pTHX_ CV *proto)
2221 PERL_ARGS_ASSERT_CV_CLONE;
2223 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2224 return S_cv_clone(aTHX_ proto, NULL, NULL);
2227 /* Called only by pp_clonecv */
2229 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2231 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2233 return S_cv_clone(aTHX_ proto, target, NULL);
2239 Returns an SV containing the name of the CV, mainly for use in error
2240 reporting. The CV may actually be a GV instead, in which case the returned
2241 SV holds the GV's name. Anything other than a GV or CV is treated as a
2242 string already holding the sub name, but this could change in the future.
2244 An SV may be passed as a second argument. If so, the name will be assigned
2245 to it and it will be returned. Otherwise the returned SV will be a new
2248 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2249 included. If the first argument is neither a CV nor a GV, this flag is
2250 ignored (subject to change).
2256 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2258 PERL_ARGS_ASSERT_CV_NAME;
2259 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2260 if (sv) sv_setsv(sv,(SV *)cv);
2261 return sv ? (sv) : (SV *)cv;
2264 SV * const retsv = sv ? (sv) : sv_newmortal();
2265 if (SvTYPE(cv) == SVt_PVCV) {
2267 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2268 sv_sethek(retsv, CvNAME_HEK(cv));
2270 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2271 sv_catpvs(retsv, "::");
2272 sv_cathek(retsv, CvNAME_HEK(cv));
2275 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2276 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2277 else gv_efullname3(retsv, CvGV(cv), NULL);
2279 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2280 else gv_efullname3(retsv,(GV *)cv,NULL);
2286 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2288 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2289 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2290 moved to a pre-existing CV struct.
2296 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2299 AV * const comppad_name = PadlistARRAY(padlist)[0];
2300 AV * const comppad = PadlistARRAY(padlist)[1];
2301 SV ** const namepad = AvARRAY(comppad_name);
2302 SV ** const curpad = AvARRAY(comppad);
2304 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2305 PERL_UNUSED_ARG(old_cv);
2307 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2308 const SV * const namesv = namepad[ix];
2309 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2310 && *SvPVX_const(namesv) == '&')
2312 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2314 SvMAGICAL(curpad[ix])
2315 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2317 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2318 if (CvOUTSIDE(innercv) == old_cv) {
2319 if (!CvWEAKOUTSIDE(innercv)) {
2320 SvREFCNT_dec(old_cv);
2321 SvREFCNT_inc_simple_void_NN(new_cv);
2323 CvOUTSIDE(innercv) = new_cv;
2326 else { /* format reference */
2327 SV * const rv = curpad[ix];
2329 if (!SvOK(rv)) continue;
2331 assert(SvWEAKREF(rv));
2332 innercv = (CV *)SvRV(rv);
2333 assert(!CvWEAKOUTSIDE(innercv));
2334 SvREFCNT_dec(CvOUTSIDE(innercv));
2335 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2342 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2344 Push a new pad frame onto the padlist, unless there's already a pad at
2345 this depth, in which case don't bother creating a new one. Then give
2346 the new pad an @_ in slot zero.
2352 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2354 PERL_ARGS_ASSERT_PAD_PUSH;
2356 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2357 PAD** const svp = PadlistARRAY(padlist);
2358 AV* const newpad = newAV();
2359 SV** const oldpad = AvARRAY(svp[depth-1]);
2360 I32 ix = AvFILLp((const AV *)svp[1]);
2361 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2362 SV** const names = AvARRAY(svp[0]);
2365 for ( ;ix > 0; ix--) {
2366 if (names_fill >= ix && PadnameLEN(names[ix])) {
2367 const char sigil = SvPVX_const(names[ix])[0];
2368 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2369 || (SvFLAGS(names[ix]) & SVpad_STATE)
2372 /* outer lexical or anon code */
2373 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2375 else { /* our own lexical */
2378 sv = MUTABLE_SV(newAV());
2379 else if (sigil == '%')
2380 sv = MUTABLE_SV(newHV());
2384 /* For flip-flop targets: */
2385 if (oldpad[ix] && SvPADTMP(oldpad[ix]))
2388 av_store(newpad, ix, sv);
2391 else if (PadnamePV(names[ix])) {
2392 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2395 /* save temporaries on recursion? */
2396 SV * const sv = newSV(0);
2397 av_store(newpad, ix, sv);
2402 av_store(newpad, 0, MUTABLE_SV(av));
2405 padlist_store(padlist, depth, newpad);
2410 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2412 Looks up the type of the lexical variable at position I<po> in the
2413 currently-compiling pad. If the variable is typed, the stash of the
2414 class to which it is typed is returned. If not, C<NULL> is returned.
2420 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2422 SV* const av = PAD_COMPNAME_SV(po);
2423 if ( SvPAD_TYPED(av) ) {
2429 #if defined(USE_ITHREADS)
2431 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2434 =for apidoc padlist_dup
2442 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2448 PERL_ARGS_ASSERT_PADLIST_DUP;
2453 cloneall = param->flags & CLONEf_COPY_STACKS
2454 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2455 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2457 max = cloneall ? PadlistMAX(srcpad) : 1;
2459 Newx(dstpad, 1, PADLIST);
2460 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2461 PadlistMAX(dstpad) = max;
2462 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2466 for (depth = 0; depth <= max; ++depth)
2467 PadlistARRAY(dstpad)[depth] =
2468 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2470 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2471 to build anything other than the first level of pads. */
2472 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2474 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2475 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2476 SV **oldpad = AvARRAY(srcpad1);
2481 PadlistARRAY(dstpad)[0] =
2482 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2483 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2487 av_extend(pad1, ix);
2488 PadlistARRAY(dstpad)[1] = pad1;
2489 pad1a = AvARRAY(pad1);
2494 for ( ;ix > 0; ix--) {
2497 } else if (names_fill >= ix && names[ix] &&
2498 PadnameLEN(names[ix])) {
2499 const char sigil = SvPVX_const(names[ix])[0];
2500 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2501 || (SvFLAGS(names[ix]) & SVpad_STATE)
2504 /* outer lexical or anon code */
2505 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2507 else { /* our own lexical */
2508 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2509 /* This is a work around for how the current
2510 implementation of ?{ } blocks in regexps
2511 interacts with lexicals. */
2512 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2517 sv = MUTABLE_SV(newAV());
2518 else if (sigil == '%')
2519 sv = MUTABLE_SV(newHV());
2526 else if (( names_fill >= ix && names[ix]
2527 && PadnamePV(names[ix]) )) {
2528 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2531 /* save temporaries on recursion? */
2532 SV * const sv = newSV(0);
2535 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2536 FIXTHAT before merging this branch.
2537 (And I know how to) */
2538 if (SvPADTMP(oldpad[ix]))
2544 args = newAV(); /* Will be @_ */
2546 pad1a[0] = (SV *)args;
2554 #endif /* USE_ITHREADS */
2557 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2560 SSize_t const oldmax = PadlistMAX(padlist);
2562 PERL_ARGS_ASSERT_PADLIST_STORE;
2566 if (key > PadlistMAX(padlist)) {
2567 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2568 (SV ***)&PadlistARRAY(padlist),
2569 (SV ***)&PadlistARRAY(padlist));
2570 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2573 ary = PadlistARRAY(padlist);
2574 SvREFCNT_dec(ary[key]);
2581 * c-indentation-style: bsd
2583 * indent-tabs-mode: nil
2586 * ex: set ts=8 sts=4 sw=4 et: