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 const PADLIST *padlist = CvPADLIST(cv);
323 bool const slabbed = !!CvSLABBED(cv);
325 PERL_ARGS_ASSERT_CV_UNDEF;
327 DEBUG_X(PerlIO_printf(Perl_debug_log,
328 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
329 PTR2UV(cv), PTR2UV(PL_comppad))
332 if (CvFILE(cv) && CvDYNFILE(cv)) {
333 Safefree(CvFILE(cv));
338 if (!CvISXSUB(cv) && CvROOT(cv)) {
339 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
340 Perl_croak(aTHX_ "Can't undef active subroutine");
343 PAD_SAVE_SETNULLPAD();
345 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
351 else if (slabbed && CvSTART(cv)) {
353 PAD_SAVE_SETNULLPAD();
355 /* discard any leaked ops */
357 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
358 opslab_force_free((OPSLAB *)CvSTART(cv));
364 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
366 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
367 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
368 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
369 else CvGV_set(cv, NULL);
371 /* This statement and the subsequence if block was pad_undef(). */
372 pad_peg("pad_undef");
377 /* Free the padlist associated with a CV.
378 If parts of it happen to be current, we null the relevant PL_*pad*
379 global vars so that we don't have any dangling references left.
380 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
381 subs to the outer of this cv. */
383 DEBUG_X(PerlIO_printf(Perl_debug_log,
384 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
385 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
388 /* detach any '&' anon children in the pad; if afterwards they
389 * are still live, fix up their CvOUTSIDEs to point to our outside,
391 /* XXX DAPM for efficiency, we should only do this if we know we have
392 * children, or integrate this loop with general cleanup */
394 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
395 CV * const outercv = CvOUTSIDE(cv);
396 const U32 seq = CvOUTSIDE_SEQ(cv);
397 PAD * const comppad_name = PadlistARRAY(padlist)[0];
398 SV ** const namepad = AvARRAY(comppad_name);
399 PAD * const comppad = PadlistARRAY(padlist)[1];
400 SV ** const curpad = AvARRAY(comppad);
401 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
402 SV * const namesv = namepad[ix];
403 if (namesv && namesv != &PL_sv_undef
404 && *SvPVX_const(namesv) == '&')
406 CV * const innercv = MUTABLE_CV(curpad[ix]);
407 U32 inner_rc = SvREFCNT(innercv);
409 assert(SvTYPE(innercv) != SVt_PVFM);
411 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
413 SvREFCNT_dec_NN(innercv);
417 /* in use, not just a prototype */
418 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
419 assert(CvWEAKOUTSIDE(innercv));
420 /* don't relink to grandfather if he's being freed */
421 if (outercv && SvREFCNT(outercv)) {
422 CvWEAKOUTSIDE_off(innercv);
423 CvOUTSIDE(innercv) = outercv;
424 CvOUTSIDE_SEQ(innercv) = seq;
425 SvREFCNT_inc_simple_void_NN(outercv);
428 CvOUTSIDE(innercv) = NULL;
435 ix = PadlistMAX(padlist);
437 PAD * const sv = PadlistARRAY(padlist)[ix--];
439 if (sv == PL_comppad) {
447 PAD * const sv = PadlistARRAY(padlist)[0];
448 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
449 PL_comppad_name = NULL;
452 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
454 CvPADLIST(cv) = NULL;
458 /* remove CvOUTSIDE unless this is an undef rather than a free */
459 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
460 if (!CvWEAKOUTSIDE(cv))
461 SvREFCNT_dec(CvOUTSIDE(cv));
462 CvOUTSIDE(cv) = NULL;
465 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
468 if (CvISXSUB(cv) && CvXSUB(cv)) {
471 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
472 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
473 * to choose an error message */
474 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
478 =for apidoc cv_forget_slab
480 When a CV has a reference count on its slab (CvSLABBED), it is responsible
481 for making sure it is freed. (Hence, no two CVs should ever have a
482 reference count on the same slab.) The CV only needs to reference the slab
483 during compilation. Once it is compiled and CvROOT attached, it has
484 finished its job, so it can forget the slab.
490 Perl_cv_forget_slab(pTHX_ CV *cv)
492 const bool slabbed = !!CvSLABBED(cv);
495 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
497 if (!slabbed) return;
501 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
502 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
504 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
508 #ifdef PERL_DEBUG_READONLY_OPS
509 const size_t refcnt = slab->opslab_refcnt;
511 OpslabREFCNT_dec(slab);
512 #ifdef PERL_DEBUG_READONLY_OPS
513 if (refcnt > 1) Slab_to_ro(slab);
519 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
521 Allocates a place in the currently-compiling
522 pad (via L<perlapi/pad_alloc>) and
523 then stores a name for that entry. I<namesv> is adopted and becomes the
524 name entry; it must already contain the name string and be sufficiently
525 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
526 added to I<namesv>. None of the other
527 processing of L<perlapi/pad_add_name_pvn>
528 is done. Returns the offset of the allocated pad slot.
534 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
536 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
538 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
540 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
543 assert(SvTYPE(namesv) == SVt_PVMG);
544 SvPAD_TYPED_on(namesv);
545 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
548 SvPAD_OUR_on(namesv);
549 SvOURSTASH_set(namesv, ourstash);
550 SvREFCNT_inc_simple_void_NN(ourstash);
552 else if (flags & padadd_STATE) {
553 SvPAD_STATE_on(namesv);
556 av_store(PL_comppad_name, offset, namesv);
557 PadnamelistMAXNAMED(PL_comppad_name) = offset;
562 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
564 Allocates a place in the currently-compiling pad for a named lexical
565 variable. Stores the name and other metadata in the name part of the
566 pad, and makes preparations to manage the variable's lexical scoping.
567 Returns the offset of the allocated pad slot.
569 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
570 If I<typestash> is non-null, the name is for a typed lexical, and this
571 identifies the type. If I<ourstash> is non-null, it's a lexical reference
572 to a package variable, and this identifies the package. The following
573 flags can be OR'ed together:
575 padadd_OUR redundantly specifies if it's a package var
576 padadd_STATE variable will retain value persistently
577 padadd_NO_DUP_CHECK skip check for lexical shadowing
583 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
584 U32 flags, HV *typestash, HV *ourstash)
590 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
592 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
593 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
596 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
598 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
599 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
602 sv_setpvn(namesv, namepv, namelen);
605 flags |= padadd_UTF8_NAME;
609 flags &= ~padadd_UTF8_NAME;
611 if ((flags & padadd_NO_DUP_CHECK) == 0) {
613 SAVEFREESV(namesv); /* in case of fatal warnings */
614 /* check for duplicate declaration */
615 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
616 SvREFCNT_inc_simple_void_NN(namesv);
620 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
622 /* not yet introduced */
623 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
624 COP_SEQ_RANGE_HIGH_set(namesv, 0);
626 if (!PL_min_intro_pending)
627 PL_min_intro_pending = offset;
628 PL_max_intro_pending = offset;
629 /* if it's not a simple scalar, replace with an AV or HV */
630 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
631 assert(SvREFCNT(PL_curpad[offset]) == 1);
632 if (namelen != 0 && *namepv == '@')
633 sv_upgrade(PL_curpad[offset], SVt_PVAV);
634 else if (namelen != 0 && *namepv == '%')
635 sv_upgrade(PL_curpad[offset], SVt_PVHV);
636 else if (namelen != 0 && *namepv == '&')
637 sv_upgrade(PL_curpad[offset], SVt_PVCV);
638 assert(SvPADMY(PL_curpad[offset]));
639 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
640 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
641 (long)offset, SvPVX(namesv),
642 PTR2UV(PL_curpad[offset])));
648 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
650 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
651 instead of a string/length pair.
657 Perl_pad_add_name_pv(pTHX_ const char *name,
658 const U32 flags, HV *typestash, HV *ourstash)
660 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
661 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
665 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
667 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
668 of an SV instead of a string/length pair.
674 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
678 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
679 namepv = SvPV(name, namelen);
681 flags |= padadd_UTF8_NAME;
682 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
686 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
688 Allocates a place in the currently-compiling pad,
689 returning the offset of the allocated pad slot.
690 No name is initially attached to the pad slot.
691 I<tmptype> is a set of flags indicating the kind of pad entry required,
692 which will be set in the value SV for the allocated pad entry:
694 SVs_PADMY named lexical variable ("my", "our", "state")
695 SVs_PADTMP unnamed temporary store
696 SVf_READONLY constant shared between recursion levels
698 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
699 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
700 does not cause the SV in the pad slot to be marked read-only, but simply
701 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
702 least should be treated as such.
704 I<optype> should be an opcode indicating the type of operation that the
705 pad entry is to support. This doesn't affect operational semantics,
706 but is used for debugging.
711 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
712 * or at least rationalise ??? */
715 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
720 PERL_UNUSED_ARG(optype);
721 ASSERT_CURPAD_ACTIVE("pad_alloc");
723 if (AvARRAY(PL_comppad) != PL_curpad)
724 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
725 AvARRAY(PL_comppad), PL_curpad);
726 if (PL_pad_reset_pending)
728 if (tmptype & SVs_PADMY) {
729 /* For a my, simply push a null SV onto the end of PL_comppad. */
730 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
731 retval = AvFILLp(PL_comppad);
734 /* For a tmp, scan the pad from PL_padix upwards
735 * for a slot which has no name and no active value.
736 * For a constant, likewise, but use PL_constpadix.
738 SV * const * const names = AvARRAY(PL_comppad_name);
739 const SSize_t names_fill = AvFILLp(PL_comppad_name);
740 const bool konst = cBOOL(tmptype & SVf_READONLY);
741 retval = konst ? PL_constpadix : PL_padix;
744 * Entries that close over unavailable variables
745 * in outer subs contain values not marked PADMY.
746 * Thus we must skip, not just pad values that are
747 * marked as current pad values, but also those with names.
748 * If pad_reset is enabled, ‘current’ means different
749 * things depending on whether we are allocating a con-
750 * stant or a target. For a target, things marked PADTMP
751 * can be reused; not so for constants.
753 if (++retval <= names_fill &&
754 (sv = names[retval]) && sv != &PL_sv_undef)
756 sv = *av_fetch(PL_comppad, retval, TRUE);
759 (SVs_PADMY|(konst ? SVs_PADTMP : 0))
761 (SVs_PADMY|SVs_PADTMP)
768 av_store(PL_comppad_name, retval, &PL_sv_no);
769 tmptype &= ~SVf_READONLY;
770 tmptype |= SVs_PADTMP;
772 *(konst ? &PL_constpadix : &PL_padix) = retval;
774 SvFLAGS(sv) |= tmptype;
775 PL_curpad = AvARRAY(PL_comppad);
777 DEBUG_X(PerlIO_printf(Perl_debug_log,
778 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
779 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
780 PL_op_name[optype]));
781 #ifdef DEBUG_LEAKING_SCALARS
782 sv->sv_debug_optype = optype;
783 sv->sv_debug_inpad = 1;
785 return (PADOFFSET)retval;
789 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
791 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
792 for an anonymous function that is lexically scoped inside the
793 currently-compiling function.
794 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
795 to the outer scope is weakened to avoid a reference loop.
797 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
799 I<optype> should be an opcode indicating the type of operation that the
800 pad entry is to support. This doesn't affect operational semantics,
801 but is used for debugging.
807 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
810 SV* const name = newSV_type(SVt_PVNV);
812 PERL_ARGS_ASSERT_PAD_ADD_ANON;
815 sv_setpvs(name, "&");
816 /* These two aren't used; just make sure they're not equal to
817 * PERL_PADSEQ_INTRO */
818 COP_SEQ_RANGE_LOW_set(name, 0);
819 COP_SEQ_RANGE_HIGH_set(name, 0);
820 ix = pad_alloc(optype, SVs_PADMY);
821 av_store(PL_comppad_name, ix, name);
822 /* XXX DAPM use PL_curpad[] ? */
823 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
824 av_store(PL_comppad, ix, (SV*)func);
826 SV *rv = newRV_noinc((SV *)func);
828 assert (SvTYPE(func) == SVt_PVFM);
829 av_store(PL_comppad, ix, rv);
831 SvPADMY_on((SV*)func);
833 /* to avoid ref loops, we never have parent + child referencing each
834 * other simultaneously */
835 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
836 assert(!CvWEAKOUTSIDE(func));
837 CvWEAKOUTSIDE_on(func);
838 SvREFCNT_dec_NN(CvOUTSIDE(func));
844 =for apidoc pad_check_dup
846 Check for duplicate declarations: report any of:
848 * a my in the current scope with the same name;
849 * an our (anywhere in the pad) with the same name and the
850 same stash as C<ourstash>
852 C<is_our> indicates that the name to check is an 'our' declaration.
858 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
862 const U32 is_our = flags & padadd_OUR;
864 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
866 ASSERT_CURPAD_ACTIVE("pad_check_dup");
868 assert((flags & ~padadd_OUR) == 0);
870 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
871 return; /* nothing to check */
873 svp = AvARRAY(PL_comppad_name);
874 top = AvFILLp(PL_comppad_name);
875 /* check the current scope */
876 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
878 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
879 SV * const sv = svp[off];
883 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
884 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
887 if (is_our && (SvPAD_OUR(sv)))
888 break; /* "our" masking "our" */
889 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
890 Perl_warner(aTHX_ packWARN(WARN_MISC),
891 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
892 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
893 *SvPVX(sv) == '&' ? "subroutine" : "variable",
895 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
896 ? "scope" : "statement"));
901 /* check the rest of the pad */
904 SV * const sv = svp[off];
908 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
909 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
910 && SvOURSTASH(sv) == ourstash
913 Perl_warner(aTHX_ packWARN(WARN_MISC),
914 "\"our\" variable %"SVf" redeclared", SVfARG(sv));
915 if ((I32)off <= PL_comppad_name_floor)
916 Perl_warner(aTHX_ packWARN(WARN_MISC),
917 "\t(Did you mean \"local\" instead of \"our\"?)\n");
927 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
929 Given the name of a lexical variable, find its position in the
930 currently-compiling pad.
931 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
932 I<flags> is reserved and must be zero.
933 If it is not in the current pad but appears in the pad of any lexically
934 enclosing scope, then a pseudo-entry for it is added in the current pad.
935 Returns the offset in the current pad,
936 or C<NOT_IN_PAD> if no such lexical is in scope.
942 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
950 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
952 pad_peg("pad_findmy_pvn");
954 if (flags & ~padadd_UTF8_NAME)
955 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
958 if (flags & padadd_UTF8_NAME) {
960 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
963 flags |= padadd_UTF8_NAME;
965 flags &= ~padadd_UTF8_NAME;
968 offset = pad_findlex(namepv, namelen, flags,
969 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
970 if ((PADOFFSET)offset != NOT_IN_PAD)
973 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
975 if (*namepv == '&') return NOT_IN_PAD;
977 /* look for an our that's being introduced; this allows
978 * our $foo = 0 unless defined $foo;
979 * to not give a warning. (Yes, this is a hack) */
981 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
982 name_svp = AvARRAY(nameav);
983 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
984 const SV * const namesv = name_svp[offset];
985 if (namesv && PadnameLEN(namesv) == namelen
987 && (SvPAD_OUR(namesv))
988 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
989 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
990 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
998 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1000 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1001 instead of a string/length pair.
1007 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1009 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1010 return pad_findmy_pvn(name, strlen(name), flags);
1014 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1016 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1017 of an SV instead of a string/length pair.
1023 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1027 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1028 namepv = SvPV(name, namelen);
1030 flags |= padadd_UTF8_NAME;
1031 return pad_findmy_pvn(namepv, namelen, flags);
1035 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1037 Find the position of the lexical C<$_> in the pad of the
1038 currently-executing function. Returns the offset in the current pad,
1039 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1040 the global one should be used instead).
1041 L</find_rundefsv> is likely to be more convenient.
1047 Perl_find_rundefsvoffset(pTHX)
1051 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1052 NULL, &out_sv, &out_flags);
1056 =for apidoc Am|SV *|find_rundefsv
1058 Find and return the variable that is named C<$_> in the lexical scope
1059 of the currently-executing function. This may be a lexical C<$_>,
1060 or will otherwise be the global one.
1066 Perl_find_rundefsv(pTHX)
1072 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1073 NULL, &namesv, &flags);
1075 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1082 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1088 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1090 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1091 NULL, &namesv, &flags);
1093 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1096 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1100 =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
1102 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1103 in the inner pads if it's found in an outer one.
1105 Returns the offset in the bottom pad of the lex or the fake lex.
1106 cv is the CV in which to start the search, and seq is the current cop_seq
1107 to match against. If warn is true, print appropriate warnings. The out_*
1108 vars return values, and so are pointers to where the returned values
1109 should be stored. out_capture, if non-null, requests that the innermost
1110 instance of the lexical is captured; out_name_sv is set to the innermost
1111 matched namesv or fake namesv; out_flags returns the flags normally
1112 associated with the IVX field of a fake namesv.
1114 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1115 then comes back down, adding fake entries
1116 as it goes. It has to be this way
1117 because fake namesvs in anon protoypes have to store in xlow the index into
1123 /* the CV has finished being compiled. This is not a sufficient test for
1124 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1125 #define CvCOMPILED(cv) CvROOT(cv)
1127 /* the CV does late binding of its lexicals */
1128 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1131 S_unavailable(pTHX_ SV *namesv)
1133 /* diag_listed_as: Variable "%s" is not available */
1134 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1135 "%se \"%"SVf"\" is not available",
1136 *SvPVX_const(namesv) == '&'
1143 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1144 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1146 I32 offset, new_offset;
1149 const PADLIST * const padlist = CvPADLIST(cv);
1150 const bool staleok = !!(flags & padadd_STALEOK);
1152 PERL_ARGS_ASSERT_PAD_FINDLEX;
1154 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1155 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1157 flags &= ~ padadd_STALEOK; /* one-shot flag */
1161 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1162 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1163 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1164 out_capture ? " capturing" : "" ));
1166 /* first, search this pad */
1168 if (padlist) { /* not an undef CV */
1169 I32 fake_offset = 0;
1170 const AV * const nameav = PadlistARRAY(padlist)[0];
1171 SV * const * const name_svp = AvARRAY(nameav);
1173 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1174 const SV * const namesv = name_svp[offset];
1175 if (namesv && PadnameLEN(namesv) == namelen
1176 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1177 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1179 if (SvFAKE(namesv)) {
1180 fake_offset = offset; /* in case we don't find a real one */
1183 /* is seq within the range _LOW to _HIGH ?
1184 * This is complicated by the fact that PL_cop_seqmax
1185 * may have wrapped around at some point */
1186 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1187 continue; /* not yet introduced */
1189 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1190 /* in compiling scope */
1192 (seq > COP_SEQ_RANGE_LOW(namesv))
1193 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1194 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1199 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1201 ( seq > COP_SEQ_RANGE_LOW(namesv)
1202 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1204 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1205 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1211 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1212 if (offset > 0) { /* not fake */
1214 *out_name_sv = name_svp[offset]; /* return the namesv */
1216 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1217 * instances. For now, we just test !CvUNIQUE(cv), but
1218 * ideally, we should detect my's declared within loops
1219 * etc - this would allow a wider range of 'not stayed
1220 * shared' warnings. We also treated already-compiled
1221 * lexes as not multi as viewed from evals. */
1223 *out_flags = CvANON(cv) ?
1225 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1226 ? PAD_FAKELEX_MULTI : 0;
1228 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1229 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1230 PTR2UV(cv), (long)offset,
1231 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1232 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1234 else { /* fake match */
1235 offset = fake_offset;
1236 *out_name_sv = name_svp[offset]; /* return the namesv */
1237 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1238 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1239 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1240 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1241 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1245 /* return the lex? */
1250 if (SvPAD_OUR(*out_name_sv)) {
1251 *out_capture = NULL;
1255 /* trying to capture from an anon prototype? */
1257 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1258 : *out_flags & PAD_FAKELEX_ANON)
1262 newSVpvn_flags(namepv, namelen,
1264 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1266 *out_capture = NULL;
1272 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1273 && !SvPAD_STATE(name_svp[offset])
1274 && warn && ckWARN(WARN_CLOSURE)) {
1276 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1277 "Variable \"%"SVf"\" will not stay shared",
1278 SVfARG(newSVpvn_flags(namepv, namelen,
1280 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1283 if (fake_offset && CvANON(cv)
1284 && CvCLONE(cv) &&!CvCLONED(cv))
1287 /* not yet caught - look further up */
1288 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1289 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1292 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1294 newwarn, out_capture, out_name_sv, out_flags);
1299 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1300 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1301 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1302 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1303 PTR2UV(cv), PTR2UV(*out_capture)));
1305 if (SvPADSTALE(*out_capture)
1306 && (!CvDEPTH(cv) || !staleok)
1307 && !SvPAD_STATE(name_svp[offset]))
1310 newSVpvn_flags(namepv, namelen,
1312 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1313 *out_capture = NULL;
1316 if (!*out_capture) {
1317 if (namelen != 0 && *namepv == '@')
1318 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1319 else if (namelen != 0 && *namepv == '%')
1320 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1321 else if (namelen != 0 && *namepv == '&')
1322 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1324 *out_capture = sv_newmortal();
1332 /* it's not in this pad - try above */
1337 /* out_capture non-null means caller wants us to capture lex; in
1338 * addition we capture ourselves unless it's an ANON/format */
1339 new_capturep = out_capture ? out_capture :
1340 CvLATE(cv) ? NULL : &new_capture;
1342 offset = pad_findlex(namepv, namelen,
1343 flags | padadd_STALEOK*(new_capturep == &new_capture),
1344 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1345 new_capturep, out_name_sv, out_flags);
1346 if ((PADOFFSET)offset == NOT_IN_PAD)
1349 /* found in an outer CV. Add appropriate fake entry to this pad */
1351 /* don't add new fake entries (via eval) to CVs that we have already
1352 * finished compiling, or to undef CVs */
1353 if (CvCOMPILED(cv) || !padlist)
1354 return 0; /* this dummy (and invalid) value isnt used by the caller */
1357 /* This relies on sv_setsv_flags() upgrading the destination to the same
1358 type as the source, independent of the flags set, and on it being
1359 "good" and only copying flag bits and pointers that it understands.
1361 SV *new_namesv = newSVsv(*out_name_sv);
1362 AV * const ocomppad_name = PL_comppad_name;
1363 PAD * const ocomppad = PL_comppad;
1364 PL_comppad_name = PadlistARRAY(padlist)[0];
1365 PL_comppad = PadlistARRAY(padlist)[1];
1366 PL_curpad = AvARRAY(PL_comppad);
1369 = pad_alloc_name(new_namesv,
1370 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1371 SvPAD_TYPED(*out_name_sv)
1372 ? SvSTASH(*out_name_sv) : NULL,
1373 SvOURSTASH(*out_name_sv)
1376 SvFAKE_on(new_namesv);
1377 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1378 "Pad addname: %ld \"%.*s\" FAKE\n",
1380 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1381 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1383 PARENT_PAD_INDEX_set(new_namesv, 0);
1384 if (SvPAD_OUR(new_namesv)) {
1385 NOOP; /* do nothing */
1387 else if (CvLATE(cv)) {
1388 /* delayed creation - just note the offset within parent pad */
1389 PARENT_PAD_INDEX_set(new_namesv, offset);
1393 /* immediate creation - capture outer value right now */
1394 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1395 /* But also note the offset, as newMYSUB needs it */
1396 PARENT_PAD_INDEX_set(new_namesv, offset);
1397 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1398 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1399 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1401 *out_name_sv = new_namesv;
1402 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1404 PL_comppad_name = ocomppad_name;
1405 PL_comppad = ocomppad;
1406 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1414 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1416 Get the value at offset I<po> in the current (compiling or executing) pad.
1417 Use macro PAD_SV instead of calling this function directly.
1423 Perl_pad_sv(pTHX_ PADOFFSET po)
1425 ASSERT_CURPAD_ACTIVE("pad_sv");
1428 Perl_croak(aTHX_ "panic: pad_sv po");
1429 DEBUG_X(PerlIO_printf(Perl_debug_log,
1430 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1431 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1433 return PL_curpad[po];
1437 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1439 Set the value at offset I<po> in the current (compiling or executing) pad.
1440 Use the macro PAD_SETSV() rather than calling this function directly.
1446 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1448 PERL_ARGS_ASSERT_PAD_SETSV;
1450 ASSERT_CURPAD_ACTIVE("pad_setsv");
1452 DEBUG_X(PerlIO_printf(Perl_debug_log,
1453 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1454 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1459 #endif /* DEBUGGING */
1462 =for apidoc m|void|pad_block_start|int full
1464 Update the pad compilation state variables on entry to a new block.
1469 /* XXX DAPM perhaps:
1470 * - integrate this in general state-saving routine ???
1471 * - combine with the state-saving going on in pad_new ???
1472 * - introduce a new SAVE type that does all this in one go ?
1476 Perl_pad_block_start(pTHX_ int full)
1478 ASSERT_CURPAD_ACTIVE("pad_block_start");
1479 SAVEI32(PL_comppad_name_floor);
1480 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1482 PL_comppad_name_fill = PL_comppad_name_floor;
1483 if (PL_comppad_name_floor < 0)
1484 PL_comppad_name_floor = 0;
1485 SAVEI32(PL_min_intro_pending);
1486 SAVEI32(PL_max_intro_pending);
1487 PL_min_intro_pending = 0;
1488 SAVEI32(PL_comppad_name_fill);
1489 SAVEI32(PL_padix_floor);
1490 /* PL_padix_floor is what PL_padix is reset to at the start of each
1491 statement, by pad_reset(). We set it when entering a new scope
1492 to keep things like this working:
1493 print "$foo$bar", do { this(); that() . "foo" };
1494 We must not let "$foo$bar" and the later concatenation share the
1496 PL_padix_floor = PL_padix;
1497 PL_pad_reset_pending = FALSE;
1501 =for apidoc m|U32|intro_my
1503 "Introduce" my variables to visible status. This is called during parsing
1504 at the end of each statement to make lexical variables visible to
1505 subsequent statements.
1517 ASSERT_CURPAD_ACTIVE("intro_my");
1518 if (! PL_min_intro_pending)
1519 return PL_cop_seqmax;
1521 svp = AvARRAY(PL_comppad_name);
1522 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1523 SV * const sv = svp[i];
1525 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1526 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1528 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1529 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1530 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1531 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1532 (long)i, SvPVX_const(sv),
1533 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1534 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1538 seq = PL_cop_seqmax;
1540 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1542 PL_min_intro_pending = 0;
1543 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1544 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1545 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1551 =for apidoc m|void|pad_leavemy
1553 Cleanup at end of scope during compilation: set the max seq number for
1554 lexicals in this scope and warn of any lexicals that never got introduced.
1560 Perl_pad_leavemy(pTHX)
1564 SV * const * const svp = AvARRAY(PL_comppad_name);
1566 PL_pad_reset_pending = FALSE;
1568 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1569 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1570 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1571 const SV * const sv = svp[off];
1572 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1573 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1574 "%"SVf" never introduced",
1578 /* "Deintroduce" my variables that are leaving with this scope. */
1579 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1580 SV * const sv = svp[off];
1581 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1582 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1584 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1585 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1586 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1587 (long)off, SvPVX_const(sv),
1588 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1589 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1591 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1592 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1593 OP *kid = newOP(OP_INTROCV, 0);
1595 o = op_prepend_elem(OP_LINESEQ, kid, o);
1600 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1602 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1603 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1608 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1610 Abandon the tmp in the current pad at offset po and replace with a
1617 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1619 ASSERT_CURPAD_LEGAL("pad_swipe");
1622 if (AvARRAY(PL_comppad) != PL_curpad)
1623 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1624 AvARRAY(PL_comppad), PL_curpad);
1625 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1626 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1627 (long)po, (long)AvFILLp(PL_comppad));
1629 DEBUG_X(PerlIO_printf(Perl_debug_log,
1630 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1631 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1634 SvREFCNT_dec(PL_curpad[po]);
1637 /* if pad tmps aren't shared between ops, then there's no need to
1638 * create a new tmp when an existing op is freed */
1639 #ifdef USE_PAD_RESET
1640 PL_curpad[po] = newSV(0);
1641 SvPADTMP_on(PL_curpad[po]);
1643 PL_curpad[po] = NULL;
1645 if (PadnamelistMAX(PL_comppad_name) != -1
1646 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1647 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1648 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1650 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1652 /* Use PL_constpadix here, not PL_padix. The latter may have been
1653 reset by pad_reset. We don’t want pad_alloc to have to scan the
1654 whole pad when allocating a constant. */
1655 if ((I32)po < PL_constpadix)
1656 PL_constpadix = po - 1;
1660 =for apidoc m|void|pad_reset
1662 Mark all the current temporaries for reuse
1667 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1668 * between OPs from different statements. During compilation, at the start
1669 * of each statement pad_reset resets PL_padix back to its previous value.
1670 * When allocating a target, pad_alloc begins its scan through the pad at
1675 #ifdef USE_PAD_RESET
1676 if (AvARRAY(PL_comppad) != PL_curpad)
1677 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1678 AvARRAY(PL_comppad), PL_curpad);
1680 DEBUG_X(PerlIO_printf(Perl_debug_log,
1681 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1682 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1683 (long)PL_padix, (long)PL_padix_floor
1687 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1688 PL_padix = PL_padix_floor;
1691 PL_pad_reset_pending = FALSE;
1695 =for apidoc Amx|void|pad_tidy|padtidy_type type
1697 Tidy up a pad at the end of compilation of the code to which it belongs.
1698 Jobs performed here are: remove most stuff from the pads of anonsub
1699 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1700 the kind of subroutine:
1702 padtidy_SUB ordinary subroutine
1703 padtidy_SUBCLONE prototype for lexical closure
1704 padtidy_FORMAT format
1709 /* XXX DAPM surely most of this stuff should be done properly
1710 * at the right time beforehand, rather than going around afterwards
1711 * cleaning up our mistakes ???
1715 Perl_pad_tidy(pTHX_ padtidy_type type)
1719 ASSERT_CURPAD_ACTIVE("pad_tidy");
1721 /* If this CV has had any 'eval-capable' ops planted in it:
1722 * i.e. it contains any of:
1726 * * use re 'eval'; /$var/
1729 * Then any anon prototypes in the chain of CVs should be marked as
1730 * cloneable, so that for example the eval's CV in
1734 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1735 * potentially have an eval executed within it.
1738 if (PL_cv_has_eval || PL_perldb) {
1740 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1741 if (cv != PL_compcv && CvCOMPILED(cv))
1742 break; /* no need to mark already-compiled code */
1744 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1745 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1752 /* extend namepad to match curpad */
1753 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1754 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1756 if (type == padtidy_SUBCLONE) {
1757 SV ** const namep = AvARRAY(PL_comppad_name);
1760 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1762 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1765 * The only things that a clonable function needs in its
1766 * pad are anonymous subs, constants and GVs.
1767 * The rest are created anew during cloning.
1769 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1770 || IS_PADGV(PL_curpad[ix]))
1773 if (!(PadnamePV(namesv) &&
1774 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1776 SvREFCNT_dec(PL_curpad[ix]);
1777 PL_curpad[ix] = NULL;
1781 else if (type == padtidy_SUB) {
1782 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1783 AV * const av = newAV(); /* Will be @_ */
1784 av_store(PL_comppad, 0, MUTABLE_SV(av));
1788 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1789 SV ** const namep = AvARRAY(PL_comppad_name);
1791 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1792 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1793 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1794 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1796 if (!SvPADMY(PL_curpad[ix])) {
1797 SvPADTMP_on(PL_curpad[ix]);
1798 } else if (!SvFAKE(namep[ix])) {
1799 /* This is a work around for how the current implementation of
1800 ?{ } blocks in regexps interacts with lexicals.
1802 One of our lexicals.
1803 Can't do this on all lexicals, otherwise sub baz() won't
1812 because completion of compiling &bar calling pad_tidy()
1813 would cause (top level) $foo to be marked as stale, and
1814 "no longer available". */
1815 SvPADSTALE_on(PL_curpad[ix]);
1819 PL_curpad = AvARRAY(PL_comppad);
1823 =for apidoc m|void|pad_free|PADOFFSET po
1825 Free the SV at offset po in the current pad.
1830 /* XXX DAPM integrate with pad_swipe ???? */
1832 Perl_pad_free(pTHX_ PADOFFSET po)
1834 #ifndef USE_PAD_RESET
1837 ASSERT_CURPAD_LEGAL("pad_free");
1840 if (AvARRAY(PL_comppad) != PL_curpad)
1841 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1842 AvARRAY(PL_comppad), PL_curpad);
1844 Perl_croak(aTHX_ "panic: pad_free po");
1846 DEBUG_X(PerlIO_printf(Perl_debug_log,
1847 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1848 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1851 #ifndef USE_PAD_RESET
1853 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1854 SvFLAGS(sv) &= ~SVs_PADTMP;
1856 if ((I32)po < PL_padix)
1862 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1864 Dump the contents of a padlist
1870 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1878 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1883 pad_name = *PadlistARRAY(padlist);
1884 pad = PadlistARRAY(padlist)[1];
1885 pname = AvARRAY(pad_name);
1886 ppad = AvARRAY(pad);
1887 Perl_dump_indent(aTHX_ level, file,
1888 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1889 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1892 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1893 const SV *namesv = pname[ix];
1894 if (namesv && !PadnameLEN(namesv)) {
1899 Perl_dump_indent(aTHX_ level+1, file,
1900 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1903 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1904 SvPVX_const(namesv),
1905 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1906 (unsigned long)PARENT_PAD_INDEX(namesv)
1910 Perl_dump_indent(aTHX_ level+1, file,
1911 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1914 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1915 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1916 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1921 Perl_dump_indent(aTHX_ level+1, file,
1922 "%2d. 0x%"UVxf"<%lu>\n",
1925 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1934 =for apidoc m|void|cv_dump|CV *cv|const char *title
1936 dump the contents of a CV
1942 S_cv_dump(pTHX_ const CV *cv, const char *title)
1944 const CV * const outside = CvOUTSIDE(cv);
1945 PADLIST* const padlist = CvPADLIST(cv);
1947 PERL_ARGS_ASSERT_CV_DUMP;
1949 PerlIO_printf(Perl_debug_log,
1950 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1953 (CvANON(cv) ? "ANON"
1954 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1955 : (cv == PL_main_cv) ? "MAIN"
1956 : CvUNIQUE(cv) ? "UNIQUE"
1957 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1960 : CvANON(outside) ? "ANON"
1961 : (outside == PL_main_cv) ? "MAIN"
1962 : CvUNIQUE(outside) ? "UNIQUE"
1963 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1965 PerlIO_printf(Perl_debug_log,
1966 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1967 do_dump_pad(1, Perl_debug_log, padlist, 1);
1970 #endif /* DEBUGGING */
1973 =for apidoc Am|CV *|cv_clone|CV *proto
1975 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1976 of the function: its code, pad structure, and other attributes.
1977 The prototype is combined with a capture of outer lexicals to which the
1978 code refers, which are taken from the currently-executing instance of
1979 the immediately surrounding code.
1984 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1987 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1990 PADLIST* const protopadlist = CvPADLIST(proto);
1991 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1992 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1993 SV** const pname = AvARRAY(protopad_name);
1994 SV** const ppad = AvARRAY(protopad);
1995 const I32 fname = AvFILLp(protopad_name);
1996 const I32 fpad = AvFILLp(protopad);
1999 bool subclones = FALSE;
2001 assert(!CvUNIQUE(proto));
2003 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2004 * reliable. The currently-running sub is always the one we need to
2006 * For my subs, the currently-running sub may not be the one we want.
2007 * We have to check whether it is a clone of CvOUTSIDE.
2008 * Note that in general for formats, CvOUTSIDE != find_runcv.
2009 * Since formats may be nested inside closures, CvOUTSIDE may point
2010 * to a prototype; we instead want the cloned parent who called us.
2014 if (CvWEAKOUTSIDE(proto))
2015 outside = find_runcv(NULL);
2017 outside = CvOUTSIDE(proto);
2018 if ((CvCLONE(outside) && ! CvCLONED(outside))
2019 || !CvPADLIST(outside)
2020 || PadlistNAMES(CvPADLIST(outside))
2021 != protopadlist->xpadl_outid) {
2022 outside = find_runcv_where(
2023 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2025 /* outside could be null */
2029 depth = outside ? CvDEPTH(outside) : 0;
2034 SAVESPTR(PL_compcv);
2036 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2039 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2041 SAVESPTR(PL_comppad_name);
2042 PL_comppad_name = protopad_name;
2043 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2045 av_fill(PL_comppad, fpad);
2047 PL_curpad = AvARRAY(PL_comppad);
2049 outpad = outside && CvPADLIST(outside)
2050 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2053 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2055 for (ix = fpad; ix > 0; ix--) {
2056 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2058 if (namesv && PadnameLEN(namesv)) { /* lexical */
2059 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2063 if (SvFAKE(namesv)) { /* lexical from outside? */
2064 /* formats may have an inactive, or even undefined, parent;
2065 but state vars are always available. */
2066 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2067 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2068 && (!outside || !CvDEPTH(outside))) ) {
2069 S_unavailable(aTHX_ namesv);
2073 SvREFCNT_inc_simple_void_NN(sv);
2076 const char sigil = SvPVX_const(namesv)[0];
2078 /* If there are state subs, we need to clone them, too.
2079 But they may need to close over variables we have
2080 not cloned yet. So we will have to do a second
2081 pass. Furthermore, there may be state subs clos-
2082 ing over other state subs’ entries, so we have
2083 to put a stub here and then clone into it on the
2085 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2086 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2088 sv = newSV_type(SVt_PVCV);
2090 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2093 /* Just provide a stub, but name it. It will be
2094 upgrade to the real thing on scope entry. */
2095 sv = newSV_type(SVt_PVCV);
2098 share_hek(SvPVX_const(namesv)+1,
2100 * (SvUTF8(namesv) ? -1 : 1),
2104 else sv = SvREFCNT_inc(ppad[ix]);
2105 else if (sigil == '@')
2106 sv = MUTABLE_SV(newAV());
2107 else if (sigil == '%')
2108 sv = MUTABLE_SV(newHV());
2112 /* reset the 'assign only once' flag on each state var */
2113 if (sigil != '&' && SvPAD_STATE(namesv))
2118 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2119 sv = SvREFCNT_inc_NN(ppad[ix]);
2129 for (ix = fpad; ix > 0; ix--) {
2130 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2131 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2132 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2133 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2136 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2141 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2146 const bool newcv = !cv;
2148 assert(!CvUNIQUE(proto));
2150 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2151 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2155 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2158 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2159 else CvGV_set(cv,CvGV(proto));
2160 CvSTASH_set(cv, CvSTASH(proto));
2162 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2164 CvSTART(cv) = CvSTART(proto);
2165 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2168 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2170 SvUTF8_on(MUTABLE_SV(cv));
2173 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2175 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2178 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2179 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2180 cv_dump(proto, "Proto");
2185 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2186 * The prototype was marked as a candiate for const-ization,
2187 * so try to grab the current const value, and if successful,
2188 * turn into a const sub:
2190 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2192 SvREFCNT_dec_NN(cv);
2193 /* For this calling case, op_const_sv returns a *copy*, which we
2194 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2195 Need to fix how lib/constant.pm works to eliminate this. */
2196 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2207 Perl_cv_clone(pTHX_ CV *proto)
2209 PERL_ARGS_ASSERT_CV_CLONE;
2211 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2212 return S_cv_clone(aTHX_ proto, NULL, NULL);
2215 /* Called only by pp_clonecv */
2217 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2219 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2221 return S_cv_clone(aTHX_ proto, target, NULL);
2225 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2227 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2228 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2229 moved to a pre-existing CV struct.
2235 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2238 AV * const comppad_name = PadlistARRAY(padlist)[0];
2239 AV * const comppad = PadlistARRAY(padlist)[1];
2240 SV ** const namepad = AvARRAY(comppad_name);
2241 SV ** const curpad = AvARRAY(comppad);
2243 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2244 PERL_UNUSED_ARG(old_cv);
2246 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2247 const SV * const namesv = namepad[ix];
2248 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2249 && *SvPVX_const(namesv) == '&')
2251 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2253 SvMAGICAL(curpad[ix])
2254 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2256 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2257 if (CvOUTSIDE(innercv) == old_cv) {
2258 if (!CvWEAKOUTSIDE(innercv)) {
2259 SvREFCNT_dec(old_cv);
2260 SvREFCNT_inc_simple_void_NN(new_cv);
2262 CvOUTSIDE(innercv) = new_cv;
2265 else { /* format reference */
2266 SV * const rv = curpad[ix];
2268 if (!SvOK(rv)) continue;
2270 assert(SvWEAKREF(rv));
2271 innercv = (CV *)SvRV(rv);
2272 assert(!CvWEAKOUTSIDE(innercv));
2273 SvREFCNT_dec(CvOUTSIDE(innercv));
2274 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2281 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2283 Push a new pad frame onto the padlist, unless there's already a pad at
2284 this depth, in which case don't bother creating a new one. Then give
2285 the new pad an @_ in slot zero.
2291 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2293 PERL_ARGS_ASSERT_PAD_PUSH;
2295 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2296 PAD** const svp = PadlistARRAY(padlist);
2297 AV* const newpad = newAV();
2298 SV** const oldpad = AvARRAY(svp[depth-1]);
2299 I32 ix = AvFILLp((const AV *)svp[1]);
2300 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2301 SV** const names = AvARRAY(svp[0]);
2304 for ( ;ix > 0; ix--) {
2305 if (names_fill >= ix && PadnameLEN(names[ix])) {
2306 const char sigil = SvPVX_const(names[ix])[0];
2307 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2308 || (SvFLAGS(names[ix]) & SVpad_STATE)
2311 /* outer lexical or anon code */
2312 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2314 else { /* our own lexical */
2317 sv = MUTABLE_SV(newAV());
2318 else if (sigil == '%')
2319 sv = MUTABLE_SV(newHV());
2322 av_store(newpad, ix, sv);
2326 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2327 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2330 /* save temporaries on recursion? */
2331 SV * const sv = newSV(0);
2332 av_store(newpad, ix, sv);
2337 av_store(newpad, 0, MUTABLE_SV(av));
2340 padlist_store(padlist, depth, newpad);
2345 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2347 Looks up the type of the lexical variable at position I<po> in the
2348 currently-compiling pad. If the variable is typed, the stash of the
2349 class to which it is typed is returned. If not, C<NULL> is returned.
2355 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2357 SV* const av = PAD_COMPNAME_SV(po);
2358 if ( SvPAD_TYPED(av) ) {
2364 #if defined(USE_ITHREADS)
2366 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2369 =for apidoc padlist_dup
2377 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2383 PERL_ARGS_ASSERT_PADLIST_DUP;
2388 cloneall = param->flags & CLONEf_COPY_STACKS
2389 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2390 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2392 max = cloneall ? PadlistMAX(srcpad) : 1;
2394 Newx(dstpad, 1, PADLIST);
2395 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2396 PadlistMAX(dstpad) = max;
2397 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2401 for (depth = 0; depth <= max; ++depth)
2402 PadlistARRAY(dstpad)[depth] =
2403 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2405 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2406 to build anything other than the first level of pads. */
2407 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2409 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2410 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2411 SV **oldpad = AvARRAY(srcpad1);
2416 PadlistARRAY(dstpad)[0] =
2417 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2418 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2422 av_extend(pad1, ix);
2423 PadlistARRAY(dstpad)[1] = pad1;
2424 pad1a = AvARRAY(pad1);
2429 for ( ;ix > 0; ix--) {
2432 } else if (names_fill >= ix && names[ix] &&
2433 PadnameLEN(names[ix])) {
2434 const char sigil = SvPVX_const(names[ix])[0];
2435 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2436 || (SvFLAGS(names[ix]) & SVpad_STATE)
2439 /* outer lexical or anon code */
2440 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2442 else { /* our own lexical */
2443 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2444 /* This is a work around for how the current
2445 implementation of ?{ } blocks in regexps
2446 interacts with lexicals. */
2447 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2452 sv = MUTABLE_SV(newAV());
2453 else if (sigil == '%')
2454 sv = MUTABLE_SV(newHV());
2462 else if (IS_PADGV(oldpad[ix])
2463 || ( names_fill >= ix && names[ix]
2464 && PadnamePV(names[ix]) )) {
2465 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2468 /* save temporaries on recursion? */
2469 SV * const sv = newSV(0);
2472 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2473 FIXTHAT before merging this branch.
2474 (And I know how to) */
2475 if (SvPADMY(oldpad[ix]))
2483 args = newAV(); /* Will be @_ */
2485 pad1a[0] = (SV *)args;
2493 #endif /* USE_ITHREADS */
2496 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2499 SSize_t const oldmax = PadlistMAX(padlist);
2501 PERL_ARGS_ASSERT_PADLIST_STORE;
2505 if (key > PadlistMAX(padlist)) {
2506 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2507 (SV ***)&PadlistARRAY(padlist),
2508 (SV ***)&PadlistARRAY(padlist));
2509 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2512 ary = PadlistARRAY(padlist);
2513 SvREFCNT_dec(ary[key]);
2520 * c-indentation-style: bsd
2522 * indent-tabs-mode: nil
2525 * ex: set ts=8 sts=4 sw=4 et: