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 =head1 Pad Data Structures
24 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
26 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
27 scratchpad, which stores lexical variables and opcode temporary and
30 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
31 not callable at will and are always thrown away after the eval"" is done
32 executing). Require'd files are simply evals without any outer lexical
35 XSUBs do not have a C<CvPADLIST>. C<dXSTARG> fetches values from C<PL_curpad>,
36 but that is really the callers pad (a slot of which is allocated by
37 every entersub). Do not get or set C<CvPADLIST> if a CV is an XSUB (as
38 determined by C<CvISXSUB()>), C<CvPADLIST> slot is reused for a different
39 internal purpose in XSUBs.
41 The PADLIST has a C array where pads are stored.
43 The 0th entry of the PADLIST is a PADNAMELIST
44 which represents the "names" or rather
45 the "static type information" for lexicals. The individual elements of a
46 PADNAMELIST are PADNAMEs. Future
47 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
48 array, so don't rely on it. See L</PadlistNAMES>.
50 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
51 at that depth of recursion into the CV. The 0th slot of a frame AV is an
52 AV which is C<@_>. Other entries are storage for variables and op targets.
54 Iterating over the PADNAMELIST iterates over all possible pad
55 items. Pad slots for targets (C<SVs_PADTMP>)
56 and GVs end up having &PL_padname_undef "names", while slots for constants
57 have C<&PL_padname_const> "names" (see C<L</pad_alloc>>). That
59 and C<&PL_padname_const> are used is an implementation detail subject to
60 change. To test for them, use C<!PadnamePV(name)> and
61 S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
63 Only C<my>/C<our> variable slots get valid names.
64 The rest are op targets/GVs/constants which are statically allocated
65 or resolved at compile time. These don't have names by which they
66 can be looked up from Perl code at run time through eval"" the way
67 C<my>/C<our> variables can be. Since they can't be looked up by "name"
68 but only by their index allocated at compile time (which is usually
69 in C<PL_op->op_targ>), wasting a name SV for them doesn't make sense.
71 The pad names in the PADNAMELIST have their PV holding the name of
72 the variable. The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
73 (low+1..high inclusive) of cop_seq numbers for which the name is
74 valid. During compilation, these fields may hold the special value
75 PERL_PADSEQ_INTRO to indicate various stages:
77 COP_SEQ_RANGE_LOW _HIGH
78 ----------------- -----
79 PERL_PADSEQ_INTRO 0 variable not yet introduced:
81 valid-seq# PERL_PADSEQ_INTRO variable in scope:
83 valid-seq# valid-seq# compilation of scope complete:
86 When a lexical var hasn't yet been introduced, it already exists from the
87 perspective of duplicate declarations, but not for variable lookups, e.g.
89 my ($x, $x); # '"my" variable $x masks earlier declaration'
90 my $x = $x; # equal to my $x = $::x;
92 For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
93 lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
94 that duplicate C<our> declarations in the same package can be detected).
95 C<PadnameGEN> is sometimes used to store the generation number during
98 If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
99 is a REFCNT'ed reference to a lexical from "outside". Such entries
100 are sometimes referred to as 'fake'. In this case, the name does not
101 use 'low' and 'high' to store a cop_seq range, since it is in scope
102 throughout. Instead 'high' stores some flags containing info about
103 the real lexical (is it declared in an anon, and is it capable of being
104 instantiated multiple times?), and for fake ANONs, 'low' contains the index
105 within the parent's pad where the lexical's value is stored, to make
108 If the 'name' is C<&> the corresponding entry in the PAD
109 is a CV representing a possible closure.
111 Note that formats are treated as anon subs, and are cloned each time
112 write is called (if necessary).
114 The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
115 and set on scope exit. This allows the
116 C<"Variable $x is not available"> warning
117 to be generated in evals, such as
119 { my $x = 1; sub f { eval '$x'} } f();
121 For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
122 but this internal state is stored in a separate pad entry.
124 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
126 During compilation, this points to the array containing the names part
127 of the pad for the currently-compiling code.
129 =for apidoc AmxU|PAD *|PL_comppad
131 During compilation, this points to the array containing the values
132 part of the pad for the currently-compiling code. (At runtime a CV may
133 have many such value arrays; at compile time just one is constructed.)
134 At runtime, this points to the array containing the currently-relevant
135 values for the pad for the currently-executing code.
137 =for apidoc AmxU|SV **|PL_curpad
139 Points directly to the body of the L</PL_comppad> array.
140 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
147 #define PERL_IN_PAD_C
149 #include "keywords.h"
151 #define COP_SEQ_RANGE_LOW_set(sv,val) \
152 STMT_START { (sv)->xpadn_low = (val); } STMT_END
153 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
154 STMT_START { (sv)->xpadn_high = (val); } STMT_END
156 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
157 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
161 Perl_set_padlist(CV * cv, PADLIST *padlist){
162 PERL_ARGS_ASSERT_SET_PADLIST;
164 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
166 assert((Size_t)padlist != 0xEFEFEFEF);
168 # error unknown pointer size
170 assert(!CvISXSUB(cv));
171 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
176 =for apidoc Am|PADLIST *|pad_new|int flags
178 Create a new padlist, updating the global variables for the
179 currently-compiling padlist to point to the new padlist. The following
180 flags can be OR'ed together:
182 padnew_CLONE this pad is for a cloned CV
183 padnew_SAVE save old globals on the save stack
184 padnew_SAVESUB also save extra stuff for start of sub
190 Perl_pad_new(pTHX_ int flags)
193 PADNAMELIST *padname;
197 ASSERT_CURPAD_LEGAL("pad_new");
199 /* save existing state, ... */
201 if (flags & padnew_SAVE) {
203 if (! (flags & padnew_CLONE)) {
204 SAVESPTR(PL_comppad_name);
205 save_strlen((STRLEN *)&PL_padix);
206 save_strlen((STRLEN *)&PL_constpadix);
207 save_strlen((STRLEN *)&PL_comppad_name_fill);
208 save_strlen((STRLEN *)&PL_min_intro_pending);
209 save_strlen((STRLEN *)&PL_max_intro_pending);
210 SAVEBOOL(PL_cv_has_eval);
211 if (flags & padnew_SAVESUB) {
212 SAVEBOOL(PL_pad_reset_pending);
217 /* ... create new pad ... */
219 Newxz(padlist, 1, PADLIST);
222 if (flags & padnew_CLONE) {
223 AV * const a0 = newAV(); /* will be @_ */
224 av_store(pad, 0, MUTABLE_SV(a0));
227 PadnamelistREFCNT(padname = PL_comppad_name)++;
230 padlist->xpadl_id = PL_padlist_generation++;
231 av_store(pad, 0, NULL);
232 padname = newPADNAMELIST(0);
233 padnamelist_store(padname, 0, &PL_padname_undef);
236 /* Most subroutines never recurse, hence only need 2 entries in the padlist
237 array - names, and depth=1. The default for av_store() is to allocate
238 0..3, and even an explicit call to av_extend() with <3 will be rounded
239 up, so we inline the allocation of the array here. */
241 PadlistMAX(padlist) = 1;
242 PadlistARRAY(padlist) = ary;
243 ary[0] = (PAD *)padname;
246 /* ... then update state variables */
249 PL_curpad = AvARRAY(pad);
251 if (! (flags & padnew_CLONE)) {
252 PL_comppad_name = padname;
253 PL_comppad_name_fill = 0;
254 PL_min_intro_pending = 0;
260 DEBUG_X(PerlIO_printf(Perl_debug_log,
261 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
262 " name=0x%" UVxf " flags=0x%" UVxf "\n",
263 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
264 PTR2UV(padname), (UV)flags
268 return (PADLIST*)padlist;
273 =head1 Embedding Functions
277 Clear out all the active components of a CV. This can happen either
278 by an explicit C<undef &foo>, or by the reference count going to zero.
279 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
280 children can still follow the full lexical scope chain.
286 Perl_cv_undef(pTHX_ CV *cv)
288 PERL_ARGS_ASSERT_CV_UNDEF;
289 cv_undef_flags(cv, 0);
293 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
295 CV cvbody;/*CV body will never be realloced inside this func,
296 so dont read it more than once, use fake CV so existing macros
297 will work, the indirection and CV head struct optimized away*/
298 SvANY(&cvbody) = SvANY(cv);
300 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
302 DEBUG_X(PerlIO_printf(Perl_debug_log,
303 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
304 PTR2UV(cv), PTR2UV(PL_comppad))
307 if (CvFILE(&cvbody)) {
308 char * file = CvFILE(&cvbody);
309 CvFILE(&cvbody) = NULL;
310 if(CvDYNFILE(&cvbody))
314 /* CvSLABBED_off(&cvbody); *//* turned off below */
315 /* release the sub's body */
316 if (!CvISXSUB(&cvbody)) {
317 if(CvROOT(&cvbody)) {
318 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
319 if (CvDEPTHunsafe(&cvbody)) {
320 assert(SvTYPE(cv) == SVt_PVCV);
321 Perl_croak_nocontext("Can't undef active subroutine");
325 PAD_SAVE_SETNULLPAD();
327 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
328 op_free(CvROOT(&cvbody));
329 CvROOT(&cvbody) = NULL;
330 CvSTART(&cvbody) = NULL;
333 else if (CvSLABBED(&cvbody)) {
334 if( CvSTART(&cvbody)) {
336 PAD_SAVE_SETNULLPAD();
338 /* discard any leaked ops */
340 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
341 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
342 CvSTART(&cvbody) = NULL;
347 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
351 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
352 CvXSUB(&cvbody) = NULL;
354 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
355 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
356 if (!(flags & CV_UNDEF_KEEP_NAME)) {
357 if (CvNAMED(&cvbody)) {
358 CvNAME_HEK_set(&cvbody, NULL);
359 CvNAMED_off(&cvbody);
361 else CvGV_set(cv, NULL);
364 /* This statement and the subsequence if block was pad_undef(). */
365 pad_peg("pad_undef");
367 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
369 const PADLIST *padlist = CvPADLIST(&cvbody);
371 /* Free the padlist associated with a CV.
372 If parts of it happen to be current, we null the relevant PL_*pad*
373 global vars so that we don't have any dangling references left.
374 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
375 subs to the outer of this cv. */
377 DEBUG_X(PerlIO_printf(Perl_debug_log,
378 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
379 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
382 /* detach any '&' anon children in the pad; if afterwards they
383 * are still live, fix up their CvOUTSIDEs to point to our outside,
386 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
387 CV * const outercv = CvOUTSIDE(&cvbody);
388 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
389 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
390 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
391 PAD * const comppad = PadlistARRAY(padlist)[1];
392 SV ** const curpad = AvARRAY(comppad);
393 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
394 PADNAME * const name = namepad[ix];
395 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
397 CV * const innercv = MUTABLE_CV(curpad[ix]);
400 assert(SvTYPE(innercv) != SVt_PVFM);
401 inner_rc = SvREFCNT(innercv);
404 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
406 SvREFCNT_dec_NN(innercv);
410 /* in use, not just a prototype */
411 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
412 && (CvOUTSIDE(innercv) == cv))
414 assert(CvWEAKOUTSIDE(innercv));
415 /* don't relink to grandfather if he's being freed */
416 if (outercv && SvREFCNT(outercv)) {
417 CvWEAKOUTSIDE_off(innercv);
418 CvOUTSIDE(innercv) = outercv;
419 CvOUTSIDE_SEQ(innercv) = seq;
420 SvREFCNT_inc_simple_void_NN(outercv);
423 CvOUTSIDE(innercv) = NULL;
430 ix = PadlistMAX(padlist);
432 PAD * const sv = PadlistARRAY(padlist)[ix--];
434 if (sv == PL_comppad) {
442 PADNAMELIST * const names = PadlistNAMES(padlist);
443 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
444 PL_comppad_name = NULL;
445 PadnamelistREFCNT_dec(names);
447 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
449 CvPADLIST_set(&cvbody, NULL);
451 else if (CvISXSUB(&cvbody))
452 CvHSCXT(&cvbody) = NULL;
453 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
456 /* remove CvOUTSIDE unless this is an undef rather than a free */
458 CV * outside = CvOUTSIDE(&cvbody);
460 CvOUTSIDE(&cvbody) = NULL;
461 if (!CvWEAKOUTSIDE(&cvbody))
462 SvREFCNT_dec_NN(outside);
465 if (CvCONST(&cvbody)) {
466 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
467 /* CvCONST_off(cv); *//* turned off below */
469 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
470 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
471 * LEXICAL, which are used to determine the sub's name. */
472 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
477 =for apidoc cv_forget_slab
479 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
480 for making sure it is freed. (Hence, no two CVs should ever have a
481 reference count on the same slab.) The CV only needs to reference the slab
482 during compilation. Once it is compiled and C<CvROOT> attached, it has
483 finished its job, so it can forget the slab.
489 Perl_cv_forget_slab(pTHX_ CV *cv)
496 slabbed = cBOOL(CvSLABBED(cv));
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|PADNAME *name|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. C<name> is adopted and
524 becomes the name entry; it must already contain the name
525 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
526 flag get added to C<name>. 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_ PADNAME *name, U32 flags, HV *typestash,
537 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
539 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
541 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
544 SvPAD_TYPED_on(name);
546 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
550 SvOURSTASH_set(name, ourstash);
551 SvREFCNT_inc_simple_void_NN(ourstash);
553 else if (flags & padadd_STATE) {
554 SvPAD_STATE_on(name);
557 padnamelist_store(PL_comppad_name, offset, name);
558 if (PadnameLEN(name) > 1)
559 PadnamelistMAXNAMED(PL_comppad_name) = offset;
564 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
566 Allocates a place in the currently-compiling pad for a named lexical
567 variable. Stores the name and other metadata in the name part of the
568 pad, and makes preparations to manage the variable's lexical scoping.
569 Returns the offset of the allocated pad slot.
571 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
572 If C<typestash> is non-null, the name is for a typed lexical, and this
573 identifies the type. If C<ourstash> is non-null, it's a lexical reference
574 to a package variable, and this identifies the package. The following
575 flags can be OR'ed together:
577 padadd_OUR redundantly specifies if it's a package var
578 padadd_STATE variable will retain value persistently
579 padadd_NO_DUP_CHECK skip check for lexical shadowing
585 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
586 U32 flags, HV *typestash, HV *ourstash)
591 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
593 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
594 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
597 name = newPADNAMEpvn(namepv, namelen);
599 if ((flags & padadd_NO_DUP_CHECK) == 0) {
601 SAVEFREEPADNAME(name); /* in case of fatal warnings */
602 /* check for duplicate declaration */
603 pad_check_dup(name, flags & padadd_OUR, ourstash);
604 PadnameREFCNT(name)++;
608 offset = pad_alloc_name(name, flags, typestash, ourstash);
610 /* not yet introduced */
611 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
612 COP_SEQ_RANGE_HIGH_set(name, 0);
614 if (!PL_min_intro_pending)
615 PL_min_intro_pending = offset;
616 PL_max_intro_pending = offset;
617 /* if it's not a simple scalar, replace with an AV or HV */
618 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
619 assert(SvREFCNT(PL_curpad[offset]) == 1);
620 if (namelen != 0 && *namepv == '@')
621 sv_upgrade(PL_curpad[offset], SVt_PVAV);
622 else if (namelen != 0 && *namepv == '%')
623 sv_upgrade(PL_curpad[offset], SVt_PVHV);
624 else if (namelen != 0 && *namepv == '&')
625 sv_upgrade(PL_curpad[offset], SVt_PVCV);
626 assert(SvPADMY(PL_curpad[offset]));
627 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
628 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
629 (long)offset, PadnamePV(name),
630 PTR2UV(PL_curpad[offset])));
636 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
638 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
639 instead of a string/length pair.
645 Perl_pad_add_name_pv(pTHX_ const char *name,
646 const U32 flags, HV *typestash, HV *ourstash)
648 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
649 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
653 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
655 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
656 of an SV instead of a string/length pair.
662 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
666 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
667 namepv = SvPVutf8(name, namelen);
668 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
672 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
674 Allocates a place in the currently-compiling pad,
675 returning the offset of the allocated pad slot.
676 No name is initially attached to the pad slot.
677 C<tmptype> is a set of flags indicating the kind of pad entry required,
678 which will be set in the value SV for the allocated pad entry:
680 SVs_PADMY named lexical variable ("my", "our", "state")
681 SVs_PADTMP unnamed temporary store
682 SVf_READONLY constant shared between recursion levels
684 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
685 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
686 does not cause the SV in the pad slot to be marked read-only, but simply
687 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
688 least should be treated as such.
690 C<optype> should be an opcode indicating the type of operation that the
691 pad entry is to support. This doesn't affect operational semantics,
692 but is used for debugging.
698 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
703 PERL_UNUSED_ARG(optype);
704 ASSERT_CURPAD_ACTIVE("pad_alloc");
706 if (AvARRAY(PL_comppad) != PL_curpad)
707 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
708 AvARRAY(PL_comppad), PL_curpad);
709 if (PL_pad_reset_pending)
711 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
712 /* For a my, simply push a null SV onto the end of PL_comppad. */
713 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
714 retval = (PADOFFSET)AvFILLp(PL_comppad);
717 /* For a tmp, scan the pad from PL_padix upwards
718 * for a slot which has no name and no active value.
719 * For a constant, likewise, but use PL_constpadix.
721 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
722 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
723 const bool konst = cBOOL(tmptype & SVf_READONLY);
724 retval = konst ? PL_constpadix : PL_padix;
727 * Entries that close over unavailable variables
728 * in outer subs contain values not marked PADMY.
729 * Thus we must skip, not just pad values that are
730 * marked as current pad values, but also those with names.
731 * If pad_reset is enabled, ‘current’ means different
732 * things depending on whether we are allocating a con-
733 * stant or a target. For a target, things marked PADTMP
734 * can be reused; not so for constants.
737 if (++retval <= names_fill &&
738 (pn = names[retval]) && PadnamePV(pn))
740 sv = *av_fetch(PL_comppad, retval, TRUE);
743 (konst ? SVs_PADTMP : 0)
751 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
752 tmptype &= ~SVf_READONLY;
753 tmptype |= SVs_PADTMP;
755 *(konst ? &PL_constpadix : &PL_padix) = retval;
757 SvFLAGS(sv) |= tmptype;
758 PL_curpad = AvARRAY(PL_comppad);
760 DEBUG_X(PerlIO_printf(Perl_debug_log,
761 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
762 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
763 PL_op_name[optype]));
764 #ifdef DEBUG_LEAKING_SCALARS
765 sv->sv_debug_optype = optype;
766 sv->sv_debug_inpad = 1;
772 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
774 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
775 for an anonymous function that is lexically scoped inside the
776 currently-compiling function.
777 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
778 to the outer scope is weakened to avoid a reference loop.
780 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
782 C<optype> should be an opcode indicating the type of operation that the
783 pad entry is to support. This doesn't affect operational semantics,
784 but is used for debugging.
790 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
793 PADNAME * const name = newPADNAMEpvn("&", 1);
795 PERL_ARGS_ASSERT_PAD_ADD_ANON;
796 assert (SvTYPE(func) == SVt_PVCV);
799 /* These two aren't used; just make sure they're not equal to
800 * PERL_PADSEQ_INTRO. They should be 0 by default. */
801 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
802 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
803 ix = pad_alloc(optype, SVs_PADMY);
804 padnamelist_store(PL_comppad_name, ix, name);
805 av_store(PL_comppad, ix, (SV*)func);
807 /* to avoid ref loops, we never have parent + child referencing each
808 * other simultaneously */
809 if (CvOUTSIDE(func)) {
810 assert(!CvWEAKOUTSIDE(func));
811 CvWEAKOUTSIDE_on(func);
812 SvREFCNT_dec_NN(CvOUTSIDE(func));
818 Perl_pad_add_weakref(pTHX_ CV* func)
820 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
821 PADNAME * const name = newPADNAMEpvn("&", 1);
822 SV * const rv = newRV_inc((SV *)func);
824 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
826 /* These two aren't used; just make sure they're not equal to
827 * PERL_PADSEQ_INTRO. They should be 0 by default. */
828 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
829 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
830 padnamelist_store(PL_comppad_name, ix, name);
832 av_store(PL_comppad, ix, rv);
836 =for apidoc pad_check_dup
838 Check for duplicate declarations: report any of:
840 * a 'my' in the current scope with the same name;
841 * an 'our' (anywhere in the pad) with the same name and the
842 same stash as 'ourstash'
844 C<is_our> indicates that the name to check is an C<"our"> declaration.
850 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
854 const U32 is_our = flags & padadd_OUR;
856 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
858 ASSERT_CURPAD_ACTIVE("pad_check_dup");
860 assert((flags & ~padadd_OUR) == 0);
862 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
863 return; /* nothing to check */
865 svp = PadnamelistARRAY(PL_comppad_name);
866 top = PadnamelistMAX(PL_comppad_name);
867 /* check the current scope */
868 for (off = top; off > PL_comppad_name_floor; off--) {
869 PADNAME * const sv = svp[off];
871 && PadnameLEN(sv) == PadnameLEN(name)
873 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
874 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
875 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
877 if (is_our && (SvPAD_OUR(sv)))
878 break; /* "our" masking "our" */
879 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
880 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
881 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
883 PL_parser->in_my == KEY_my ? "my" :
884 PL_parser->in_my == KEY_sigvar ? "my" :
886 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
888 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
889 ? "scope" : "statement"));
894 /* check the rest of the pad */
897 PADNAME * const sv = svp[off];
899 && PadnameLEN(sv) == PadnameLEN(name)
901 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
902 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
903 && SvOURSTASH(sv) == ourstash
904 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
906 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
907 "\"our\" variable %" PNf " redeclared", PNfARG(sv));
908 if (off <= PL_comppad_name_floor)
909 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
910 "\t(Did you mean \"local\" instead of \"our\"?)\n");
920 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
922 Given the name of a lexical variable, find its position in the
923 currently-compiling pad.
924 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
925 C<flags> is reserved and must be zero.
926 If it is not in the current pad but appears in the pad of any lexically
927 enclosing scope, then a pseudo-entry for it is added in the current pad.
928 Returns the offset in the current pad,
929 or C<NOT_IN_PAD> if no such lexical is in scope.
935 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
940 const PADNAMELIST *namelist;
943 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
945 pad_peg("pad_findmy_pvn");
948 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
951 /* compilation errors can zero PL_compcv */
955 offset = pad_findlex(namepv, namelen, flags,
956 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
957 if (offset != NOT_IN_PAD)
960 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
962 if (*namepv == '&') return NOT_IN_PAD;
964 /* look for an our that's being introduced; this allows
965 * our $foo = 0 unless defined $foo;
966 * to not give a warning. (Yes, this is a hack) */
968 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
969 name_p = PadnamelistARRAY(namelist);
970 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
971 const PADNAME * const name = name_p[offset];
972 if (name && PadnameLEN(name) == namelen
973 && !PadnameOUTER(name)
974 && (PadnameIsOUR(name))
975 && ( PadnamePV(name) == namepv
976 || memEQ(PadnamePV(name), namepv, namelen) )
977 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
985 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
987 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
988 instead of a string/length pair.
994 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
996 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
997 return pad_findmy_pvn(name, strlen(name), flags);
1001 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1003 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1004 of an SV instead of a string/length pair.
1010 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1014 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1015 namepv = SvPVutf8(name, namelen);
1016 return pad_findmy_pvn(namepv, namelen, flags);
1020 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1022 Until the lexical C<$_> feature was removed, this function would
1023 find the position of the lexical C<$_> in the pad of the
1024 currently-executing function and return the offset in the current pad,
1027 Now it always returns C<NOT_IN_PAD>.
1033 Perl_find_rundefsvoffset(pTHX)
1035 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1040 =for apidoc Am|SV *|find_rundefsv
1042 Returns the global variable C<$_>.
1048 Perl_find_rundefsv(pTHX)
1054 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
1056 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1057 in the inner pads if it's found in an outer one.
1059 Returns the offset in the bottom pad of the lex or the fake lex.
1060 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1061 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1062 vars return values, and so are pointers to where the returned values
1063 should be stored. C<out_capture>, if non-null, requests that the innermost
1064 instance of the lexical is captured; C<out_name> is set to the innermost
1065 matched pad name or fake pad name; C<out_flags> returns the flags normally
1066 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1068 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1069 then comes back down, adding fake entries
1070 as it goes. It has to be this way
1071 because fake names in anon protoypes have to store in C<xpadn_low> the
1072 index into the parent pad.
1077 /* the CV has finished being compiled. This is not a sufficient test for
1078 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1079 #define CvCOMPILED(cv) CvROOT(cv)
1081 /* the CV does late binding of its lexicals */
1082 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1085 S_unavailable(pTHX_ PADNAME *name)
1087 /* diag_listed_as: Variable "%s" is not available */
1088 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1089 "%se \"%" PNf "\" is not available",
1090 *PadnamePV(name) == '&'
1097 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1098 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1100 PADOFFSET offset, new_offset;
1103 const PADLIST * const padlist = CvPADLIST(cv);
1104 const bool staleok = !!(flags & padadd_STALEOK);
1106 PERL_ARGS_ASSERT_PAD_FINDLEX;
1108 flags &= ~ padadd_STALEOK; /* one-shot flag */
1110 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1115 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1116 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1117 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1118 out_capture ? " capturing" : "" ));
1120 /* first, search this pad */
1122 if (padlist) { /* not an undef CV */
1123 PADOFFSET fake_offset = 0;
1124 const PADNAMELIST * const names = PadlistNAMES(padlist);
1125 PADNAME * const * const name_p = PadnamelistARRAY(names);
1127 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1128 const PADNAME * const name = name_p[offset];
1129 if (name && PadnameLEN(name) == namelen
1130 && ( PadnamePV(name) == namepv
1131 || memEQ(PadnamePV(name), namepv, namelen) ))
1133 if (PadnameOUTER(name)) {
1134 fake_offset = offset; /* in case we don't find a real one */
1137 if (PadnameIN_SCOPE(name, seq))
1142 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1143 if (offset > 0) { /* not fake */
1145 *out_name = name_p[offset]; /* return the name */
1147 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1148 * instances. For now, we just test !CvUNIQUE(cv), but
1149 * ideally, we should detect my's declared within loops
1150 * etc - this would allow a wider range of 'not stayed
1151 * shared' warnings. We also treated already-compiled
1152 * lexes as not multi as viewed from evals. */
1154 *out_flags = CvANON(cv) ?
1156 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1157 ? PAD_FAKELEX_MULTI : 0;
1159 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1160 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1161 PTR2UV(cv), (long)offset,
1162 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1163 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1165 else { /* fake match */
1166 offset = fake_offset;
1167 *out_name = name_p[offset]; /* return the name */
1168 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1169 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1170 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1171 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1172 (unsigned long) PARENT_PAD_INDEX(*out_name)
1176 /* return the lex? */
1181 if (PadnameIsOUR(*out_name)) {
1182 *out_capture = NULL;
1186 /* trying to capture from an anon prototype? */
1188 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1189 : *out_flags & PAD_FAKELEX_ANON)
1195 *out_capture = NULL;
1201 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1202 && !PadnameIsSTATE(name_p[offset])
1203 && warn && ckWARN(WARN_CLOSURE)) {
1205 /* diag_listed_as: Variable "%s" will not stay
1207 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1208 "%se \"%" UTF8f "\" will not stay shared",
1209 *namepv == '&' ? "Subroutin" : "Variabl",
1210 UTF8fARG(1, namelen, namepv));
1213 if (fake_offset && CvANON(cv)
1214 && CvCLONE(cv) &&!CvCLONED(cv))
1217 /* not yet caught - look further up */
1218 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1219 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1222 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1224 newwarn, out_capture, out_name, out_flags);
1229 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1230 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1231 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1232 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1233 PTR2UV(cv), PTR2UV(*out_capture)));
1235 if (SvPADSTALE(*out_capture)
1236 && (!CvDEPTH(cv) || !staleok)
1237 && !PadnameIsSTATE(name_p[offset]))
1241 *out_capture = NULL;
1244 if (!*out_capture) {
1245 if (namelen != 0 && *namepv == '@')
1246 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1247 else if (namelen != 0 && *namepv == '%')
1248 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1249 else if (namelen != 0 && *namepv == '&')
1250 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1252 *out_capture = sv_newmortal();
1260 /* it's not in this pad - try above */
1265 /* out_capture non-null means caller wants us to capture lex; in
1266 * addition we capture ourselves unless it's an ANON/format */
1267 new_capturep = out_capture ? out_capture :
1268 CvLATE(cv) ? NULL : &new_capture;
1270 offset = pad_findlex(namepv, namelen,
1271 flags | padadd_STALEOK*(new_capturep == &new_capture),
1272 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1273 new_capturep, out_name, out_flags);
1274 if (offset == NOT_IN_PAD)
1277 /* found in an outer CV. Add appropriate fake entry to this pad */
1279 /* don't add new fake entries (via eval) to CVs that we have already
1280 * finished compiling, or to undef CVs */
1281 if (CvCOMPILED(cv) || !padlist)
1282 return 0; /* this dummy (and invalid) value isnt used by the caller */
1285 PADNAME *new_name = newPADNAMEouter(*out_name);
1286 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1287 PAD * const ocomppad = PL_comppad;
1288 PL_comppad_name = PadlistNAMES(padlist);
1289 PL_comppad = PadlistARRAY(padlist)[1];
1290 PL_curpad = AvARRAY(PL_comppad);
1293 = pad_alloc_name(new_name,
1294 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1295 PadnameTYPE(*out_name),
1296 PadnameOURSTASH(*out_name)
1299 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1300 "Pad addname: %ld \"%.*s\" FAKE\n",
1302 (int) PadnameLEN(new_name),
1303 PadnamePV(new_name)));
1304 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1306 PARENT_PAD_INDEX_set(new_name, 0);
1307 if (PadnameIsOUR(new_name)) {
1308 NOOP; /* do nothing */
1310 else if (CvLATE(cv)) {
1311 /* delayed creation - just note the offset within parent pad */
1312 PARENT_PAD_INDEX_set(new_name, offset);
1316 /* immediate creation - capture outer value right now */
1317 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1318 /* But also note the offset, as newMYSUB needs it */
1319 PARENT_PAD_INDEX_set(new_name, offset);
1320 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1321 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1322 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1324 *out_name = new_name;
1325 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1327 PL_comppad_name = ocomppad_name;
1328 PL_comppad = ocomppad;
1329 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1337 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1339 Get the value at offset C<po> in the current (compiling or executing) pad.
1340 Use macro C<PAD_SV> instead of calling this function directly.
1346 Perl_pad_sv(pTHX_ PADOFFSET po)
1348 ASSERT_CURPAD_ACTIVE("pad_sv");
1351 Perl_croak(aTHX_ "panic: pad_sv po");
1352 DEBUG_X(PerlIO_printf(Perl_debug_log,
1353 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1354 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1356 return PL_curpad[po];
1360 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1362 Set the value at offset C<po> in the current (compiling or executing) pad.
1363 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1369 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1371 PERL_ARGS_ASSERT_PAD_SETSV;
1373 ASSERT_CURPAD_ACTIVE("pad_setsv");
1375 DEBUG_X(PerlIO_printf(Perl_debug_log,
1376 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1377 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1382 #endif /* DEBUGGING */
1385 =for apidoc m|void|pad_block_start|int full
1387 Update the pad compilation state variables on entry to a new block.
1393 Perl_pad_block_start(pTHX_ int full)
1395 ASSERT_CURPAD_ACTIVE("pad_block_start");
1396 save_strlen((STRLEN *)&PL_comppad_name_floor);
1397 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1399 PL_comppad_name_fill = PL_comppad_name_floor;
1400 if (PL_comppad_name_floor < 0)
1401 PL_comppad_name_floor = 0;
1402 save_strlen((STRLEN *)&PL_min_intro_pending);
1403 save_strlen((STRLEN *)&PL_max_intro_pending);
1404 PL_min_intro_pending = 0;
1405 save_strlen((STRLEN *)&PL_comppad_name_fill);
1406 save_strlen((STRLEN *)&PL_padix_floor);
1407 /* PL_padix_floor is what PL_padix is reset to at the start of each
1408 statement, by pad_reset(). We set it when entering a new scope
1409 to keep things like this working:
1410 print "$foo$bar", do { this(); that() . "foo" };
1411 We must not let "$foo$bar" and the later concatenation share the
1413 PL_padix_floor = PL_padix;
1414 PL_pad_reset_pending = FALSE;
1418 =for apidoc Am|U32|intro_my
1420 "Introduce" C<my> variables to visible status. This is called during parsing
1421 at the end of each statement to make lexical variables visible to subsequent
1434 ASSERT_CURPAD_ACTIVE("intro_my");
1435 if (PL_compiling.cop_seq) {
1436 seq = PL_compiling.cop_seq;
1437 PL_compiling.cop_seq = 0;
1440 seq = PL_cop_seqmax;
1441 if (! PL_min_intro_pending)
1444 svp = PadnamelistARRAY(PL_comppad_name);
1445 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1446 PADNAME * const sv = svp[i];
1448 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1449 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1451 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1452 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1453 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1454 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1455 (long)i, PadnamePV(sv),
1456 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1457 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1462 PL_min_intro_pending = 0;
1463 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1464 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1465 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1471 =for apidoc m|void|pad_leavemy
1473 Cleanup at end of scope during compilation: set the max seq number for
1474 lexicals in this scope and warn of any lexicals that never got introduced.
1480 Perl_pad_leavemy(pTHX)
1484 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1486 PL_pad_reset_pending = FALSE;
1488 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1489 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1490 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1491 const PADNAME * const name = svp[off];
1492 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1493 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1494 "%" PNf " never introduced",
1498 /* "Deintroduce" my variables that are leaving with this scope. */
1499 for (off = PadnamelistMAX(PL_comppad_name);
1500 off > PL_comppad_name_fill; off--) {
1501 PADNAME * const sv = svp[off];
1502 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1503 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1505 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1506 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1507 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1508 (long)off, PadnamePV(sv),
1509 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1510 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1512 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1513 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1514 OP *kid = newOP(OP_INTROCV, 0);
1516 o = op_prepend_elem(OP_LINESEQ, kid, o);
1521 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1522 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1527 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1529 Abandon the tmp in the current pad at offset C<po> and replace with a
1536 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1538 ASSERT_CURPAD_LEGAL("pad_swipe");
1541 if (AvARRAY(PL_comppad) != PL_curpad)
1542 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1543 AvARRAY(PL_comppad), PL_curpad);
1544 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1545 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1546 (long)po, (long)AvFILLp(PL_comppad));
1548 DEBUG_X(PerlIO_printf(Perl_debug_log,
1549 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1550 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1553 SvREFCNT_dec(PL_curpad[po]);
1556 /* if pad tmps aren't shared between ops, then there's no need to
1557 * create a new tmp when an existing op is freed */
1558 #ifdef USE_PAD_RESET
1559 PL_curpad[po] = newSV(0);
1560 SvPADTMP_on(PL_curpad[po]);
1562 PL_curpad[po] = NULL;
1564 if (PadnamelistMAX(PL_comppad_name) != -1
1565 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1566 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1567 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1569 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1571 /* Use PL_constpadix here, not PL_padix. The latter may have been
1572 reset by pad_reset. We don’t want pad_alloc to have to scan the
1573 whole pad when allocating a constant. */
1574 if (po < PL_constpadix)
1575 PL_constpadix = po - 1;
1579 =for apidoc m|void|pad_reset
1581 Mark all the current temporaries for reuse
1586 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1587 * between OPs from different statements. During compilation, at the start
1588 * of each statement pad_reset resets PL_padix back to its previous value.
1589 * When allocating a target, pad_alloc begins its scan through the pad at
1594 #ifdef USE_PAD_RESET
1595 if (AvARRAY(PL_comppad) != PL_curpad)
1596 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1597 AvARRAY(PL_comppad), PL_curpad);
1599 DEBUG_X(PerlIO_printf(Perl_debug_log,
1600 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1601 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1602 (long)PL_padix, (long)PL_padix_floor
1606 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1607 PL_padix = PL_padix_floor;
1610 PL_pad_reset_pending = FALSE;
1614 =for apidoc Amx|void|pad_tidy|padtidy_type type
1616 Tidy up a pad at the end of compilation of the code to which it belongs.
1617 Jobs performed here are: remove most stuff from the pads of anonsub
1618 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1619 the kind of subroutine:
1621 padtidy_SUB ordinary subroutine
1622 padtidy_SUBCLONE prototype for lexical closure
1623 padtidy_FORMAT format
1629 Perl_pad_tidy(pTHX_ padtidy_type type)
1633 ASSERT_CURPAD_ACTIVE("pad_tidy");
1635 /* If this CV has had any 'eval-capable' ops planted in it:
1636 * i.e. it contains any of:
1640 * * use re 'eval'; /$var/
1643 * Then any anon prototypes in the chain of CVs should be marked as
1644 * cloneable, so that for example the eval's CV in
1648 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1649 * potentially have an eval executed within it.
1652 if (PL_cv_has_eval || PL_perldb) {
1654 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1655 if (cv != PL_compcv && CvCOMPILED(cv))
1656 break; /* no need to mark already-compiled code */
1658 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1659 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1666 /* extend namepad to match curpad */
1667 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1668 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1670 if (type == padtidy_SUBCLONE) {
1671 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1674 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1676 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1679 * The only things that a clonable function needs in its
1680 * pad are anonymous subs, constants and GVs.
1681 * The rest are created anew during cloning.
1683 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1686 if (!(PadnamePV(namesv) &&
1687 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1689 SvREFCNT_dec(PL_curpad[ix]);
1690 PL_curpad[ix] = NULL;
1694 else if (type == padtidy_SUB) {
1695 AV * const av = newAV(); /* Will be @_ */
1696 av_store(PL_comppad, 0, MUTABLE_SV(av));
1700 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1701 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1703 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1704 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1705 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1707 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1708 /* This is a work around for how the current implementation of
1709 ?{ } blocks in regexps interacts with lexicals.
1711 One of our lexicals.
1712 Can't do this on all lexicals, otherwise sub baz() won't
1721 because completion of compiling &bar calling pad_tidy()
1722 would cause (top level) $foo to be marked as stale, and
1723 "no longer available". */
1724 SvPADSTALE_on(PL_curpad[ix]);
1728 PL_curpad = AvARRAY(PL_comppad);
1732 =for apidoc m|void|pad_free|PADOFFSET po
1734 Free the SV at offset po in the current pad.
1740 Perl_pad_free(pTHX_ PADOFFSET po)
1742 #ifndef USE_PAD_RESET
1745 ASSERT_CURPAD_LEGAL("pad_free");
1748 if (AvARRAY(PL_comppad) != PL_curpad)
1749 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1750 AvARRAY(PL_comppad), PL_curpad);
1752 Perl_croak(aTHX_ "panic: pad_free po");
1754 DEBUG_X(PerlIO_printf(Perl_debug_log,
1755 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1756 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1759 #ifndef USE_PAD_RESET
1761 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1762 SvFLAGS(sv) &= ~SVs_PADTMP;
1770 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1772 Dump the contents of a padlist
1778 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1780 const PADNAMELIST *pad_name;
1786 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1791 pad_name = PadlistNAMES(padlist);
1792 pad = PadlistARRAY(padlist)[1];
1793 pname = PadnamelistARRAY(pad_name);
1794 ppad = AvARRAY(pad);
1795 Perl_dump_indent(aTHX_ level, file,
1796 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1797 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1800 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1801 const PADNAME *namesv = pname[ix];
1802 if (namesv && !PadnameLEN(namesv)) {
1806 if (PadnameOUTER(namesv))
1807 Perl_dump_indent(aTHX_ level+1, file,
1808 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1811 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1813 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1814 (unsigned long)PARENT_PAD_INDEX(namesv)
1818 Perl_dump_indent(aTHX_ level+1, file,
1819 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1822 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1823 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1824 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1829 Perl_dump_indent(aTHX_ level+1, file,
1830 "%2d. 0x%" UVxf "<%lu>\n",
1833 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1842 =for apidoc m|void|cv_dump|CV *cv|const char *title
1844 dump the contents of a CV
1850 S_cv_dump(pTHX_ const CV *cv, const char *title)
1852 const CV * const outside = CvOUTSIDE(cv);
1853 PADLIST* const padlist = CvPADLIST(cv);
1855 PERL_ARGS_ASSERT_CV_DUMP;
1857 PerlIO_printf(Perl_debug_log,
1858 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1861 (CvANON(cv) ? "ANON"
1862 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1863 : (cv == PL_main_cv) ? "MAIN"
1864 : CvUNIQUE(cv) ? "UNIQUE"
1865 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1868 : CvANON(outside) ? "ANON"
1869 : (outside == PL_main_cv) ? "MAIN"
1870 : CvUNIQUE(outside) ? "UNIQUE"
1871 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1873 PerlIO_printf(Perl_debug_log,
1874 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1875 do_dump_pad(1, Perl_debug_log, padlist, 1);
1878 #endif /* DEBUGGING */
1881 =for apidoc Am|CV *|cv_clone|CV *proto
1883 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1884 of the function: its code, pad structure, and other attributes.
1885 The prototype is combined with a capture of outer lexicals to which the
1886 code refers, which are taken from the currently-executing instance of
1887 the immediately surrounding code.
1892 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1895 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1899 PADLIST* const protopadlist = CvPADLIST(proto);
1900 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1901 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1902 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1903 SV** const ppad = AvARRAY(protopad);
1904 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1905 const PADOFFSET fpad = AvFILLp(protopad);
1909 bool trouble = FALSE;
1911 assert(!CvUNIQUE(proto));
1913 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1914 * reliable. The currently-running sub is always the one we need to
1916 * For my subs, the currently-running sub may not be the one we want.
1917 * We have to check whether it is a clone of CvOUTSIDE.
1918 * Note that in general for formats, CvOUTSIDE != find_runcv.
1919 * Since formats may be nested inside closures, CvOUTSIDE may point
1920 * to a prototype; we instead want the cloned parent who called us.
1924 if (CvWEAKOUTSIDE(proto))
1925 outside = find_runcv(NULL);
1927 outside = CvOUTSIDE(proto);
1928 if ((CvCLONE(outside) && ! CvCLONED(outside))
1929 || !CvPADLIST(outside)
1930 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1931 outside = find_runcv_where(
1932 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1934 /* outside could be null */
1938 depth = outside ? CvDEPTH(outside) : 0;
1943 SAVESPTR(PL_compcv);
1945 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1948 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1950 SAVESPTR(PL_comppad_name);
1951 PL_comppad_name = protopad_name;
1952 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1953 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1955 av_fill(PL_comppad, fpad);
1957 PL_curpad = AvARRAY(PL_comppad);
1959 outpad = outside && CvPADLIST(outside)
1960 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1962 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1964 for (ix = fpad; ix > 0; ix--) {
1965 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1967 if (namesv && PadnameLEN(namesv)) { /* lexical */
1968 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1972 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1973 /* formats may have an inactive, or even undefined, parent;
1974 but state vars are always available. */
1975 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
1976 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
1977 && (!outside || !CvDEPTH(outside))) ) {
1978 S_unavailable(aTHX_ namesv);
1982 SvREFCNT_inc_simple_void_NN(sv);
1985 const char sigil = PadnamePV(namesv)[0];
1987 /* If there are state subs, we need to clone them, too.
1988 But they may need to close over variables we have
1989 not cloned yet. So we will have to do a second
1990 pass. Furthermore, there may be state subs clos-
1991 ing over other state subs’ entries, so we have
1992 to put a stub here and then clone into it on the
1994 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
1995 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
1997 if (CvOUTSIDE(ppad[ix]) != proto)
1999 sv = newSV_type(SVt_PVCV);
2002 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2005 /* Just provide a stub, but name it. It will be
2006 upgraded to the real thing on scope entry. */
2009 PERL_HASH(hash, PadnamePV(namesv)+1,
2010 PadnameLEN(namesv) - 1);
2011 sv = newSV_type(SVt_PVCV);
2014 share_hek(PadnamePV(namesv)+1,
2015 1 - PadnameLEN(namesv),
2020 else sv = SvREFCNT_inc(ppad[ix]);
2021 else if (sigil == '@')
2022 sv = MUTABLE_SV(newAV());
2023 else if (sigil == '%')
2024 sv = MUTABLE_SV(newHV());
2027 /* reset the 'assign only once' flag on each state var */
2028 if (sigil != '&' && SvPAD_STATE(namesv))
2033 else if (namesv && PadnamePV(namesv)) {
2034 sv = SvREFCNT_inc_NN(ppad[ix]);
2045 if (trouble || cloned) {
2046 /* Uh-oh, we have trouble! At least one of the state subs here
2047 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2048 could be pointing to another state protosub that we are
2049 about to clone. So we have to track which sub clones come
2050 from which protosubs. If the CvOUTSIDE pointer for a parti-
2051 cular sub points to something we have not cloned yet, we
2052 delay cloning it. We must loop through the pad entries,
2053 until we get a full pass with no cloning. If any uncloned
2054 subs remain (probably nested inside anonymous or ‘my’ subs),
2055 then they get cloned in a final pass.
2057 bool cloned_in_this_pass;
2059 cloned = (HV *)sv_2mortal((SV *)newHV());
2061 cloned_in_this_pass = FALSE;
2062 for (ix = fpad; ix > 0; ix--) {
2063 PADNAME * const name =
2064 (ix <= fname) ? pname[ix] : NULL;
2065 if (name && name != &PL_padname_undef
2066 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2067 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2069 CV * const protokey = CvOUTSIDE(ppad[ix]);
2070 CV ** const cvp = protokey == proto
2072 : (CV **)hv_fetch(cloned, (char *)&protokey,
2075 S_cv_clone(aTHX_ (CV *)ppad[ix],
2076 (CV *)PL_curpad[ix],
2078 (void)hv_store(cloned, (char *)&ppad[ix],
2080 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2083 cloned_in_this_pass = TRUE;
2087 } while (cloned_in_this_pass);
2089 for (ix = fpad; ix > 0; ix--) {
2090 PADNAME * const name =
2091 (ix <= fname) ? pname[ix] : NULL;
2092 if (name && name != &PL_padname_undef
2093 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2094 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2095 S_cv_clone(aTHX_ (CV *)ppad[ix],
2096 (CV *)PL_curpad[ix],
2097 CvOUTSIDE(ppad[ix]), cloned);
2100 else for (ix = fpad; ix > 0; ix--) {
2101 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2102 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2103 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2104 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2109 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2113 /* Constant sub () { $x } closing over $x:
2114 * The prototype was marked as a candiate for const-ization,
2115 * so try to grab the current const value, and if successful,
2116 * turn into a const sub:
2119 OP *o = CvSTART(cv);
2121 for (; o; o = o->op_next)
2122 if (o->op_type == OP_PADSV)
2124 ASSUME(o->op_type == OP_PADSV);
2125 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2126 /* the candidate should have 1 ref from this pad and 1 ref
2127 * from the parent */
2128 if (const_sv && SvREFCNT(const_sv) == 2) {
2129 const bool was_method = cBOOL(CvMETHOD(cv));
2130 bool copied = FALSE;
2132 PADNAME * const pn =
2133 PadlistNAMESARRAY(CvPADLIST(outside))
2134 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2135 CvPADLIST(cv))[o->op_targ])];
2136 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2138 if (PadnameLVALUE(pn)) {
2139 /* We have a lexical that is potentially modifiable
2140 elsewhere, so making a constant will break clo-
2141 sure behaviour. If this is a ‘simple lexical
2142 op tree’, i.e., sub(){$x}, emit a deprecation
2143 warning, but continue to exhibit the old behav-
2144 iour of making it a constant based on the ref-
2145 count of the candidate variable.
2147 A simple lexical op tree looks like this:
2155 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2159 Perl_ck_warner_d(aTHX_
2160 packWARN(WARN_DEPRECATED),
2161 "Constants from lexical "
2162 "variables potentially "
2163 "modified elsewhere are "
2164 "deprecated. This will not "
2165 "be allowed in Perl 5.32");
2166 /* We *copy* the lexical variable, and donate the
2167 copy to newCONSTSUB. Yes, this is ugly, and
2168 should be killed. We need to do this for the
2169 time being, however, because turning on SvPADTMP
2170 on a lexical will have observable effects
2172 const_sv = newSVsv(const_sv);
2180 SvREFCNT_inc_simple_void_NN(const_sv);
2181 /* If the lexical is not used elsewhere, it is safe to turn on
2182 SvPADTMP, since it is only when it is used in lvalue con-
2183 text that the difference is observable. */
2184 SvREADONLY_on(const_sv);
2185 SvPADTMP_on(const_sv);
2186 SvREFCNT_dec_NN(cv);
2187 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2201 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2206 const bool newcv = !cv;
2208 assert(!CvUNIQUE(proto));
2210 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2211 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2215 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2218 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2219 else CvGV_set(cv,CvGV(proto));
2220 CvSTASH_set(cv, CvSTASH(proto));
2222 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2224 CvSTART(cv) = CvSTART(proto);
2225 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2228 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2230 SvUTF8_on(MUTABLE_SV(cv));
2233 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2235 if (CvPADLIST(proto))
2236 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2239 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2240 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2241 cv_dump(proto, "Proto");
2249 Perl_cv_clone(pTHX_ CV *proto)
2251 PERL_ARGS_ASSERT_CV_CLONE;
2253 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2254 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2257 /* Called only by pp_clonecv */
2259 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2261 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2263 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2269 Returns an SV containing the name of the CV, mainly for use in error
2270 reporting. The CV may actually be a GV instead, in which case the returned
2271 SV holds the GV's name. Anything other than a GV or CV is treated as a
2272 string already holding the sub name, but this could change in the future.
2274 An SV may be passed as a second argument. If so, the name will be assigned
2275 to it and it will be returned. Otherwise the returned SV will be a new
2278 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2279 included. If the first argument is neither a CV nor a GV, this flag is
2280 ignored (subject to change).
2286 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2288 PERL_ARGS_ASSERT_CV_NAME;
2289 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2290 if (sv) sv_setsv(sv,(SV *)cv);
2291 return sv ? (sv) : (SV *)cv;
2294 SV * const retsv = sv ? (sv) : sv_newmortal();
2295 if (SvTYPE(cv) == SVt_PVCV) {
2297 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2298 sv_sethek(retsv, CvNAME_HEK(cv));
2300 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2301 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2303 sv_setpvs(retsv, "__ANON__");
2304 sv_catpvs(retsv, "::");
2305 sv_cathek(retsv, CvNAME_HEK(cv));
2308 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2309 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2310 else gv_efullname3(retsv, CvGV(cv), NULL);
2312 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2313 else gv_efullname3(retsv,(GV *)cv,NULL);
2319 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2321 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2322 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2323 moved to a pre-existing CV struct.
2329 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2332 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2333 AV * const comppad = PadlistARRAY(padlist)[1];
2334 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2335 SV ** const curpad = AvARRAY(comppad);
2337 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2338 PERL_UNUSED_ARG(old_cv);
2340 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2341 const PADNAME *name = namepad[ix];
2342 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2343 && *PadnamePV(name) == '&')
2345 CV *innercv = MUTABLE_CV(curpad[ix]);
2346 if (UNLIKELY(PadnameOUTER(name))) {
2348 PADNAME **names = namepad;
2350 while (PadnameOUTER(name)) {
2351 assert(SvTYPE(cv) == SVt_PVCV);
2353 names = PadlistNAMESARRAY(CvPADLIST(cv));
2354 i = PARENT_PAD_INDEX(name);
2357 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2359 if (SvTYPE(innercv) == SVt_PVCV) {
2360 /* XXX 0afba48f added code here to check for a proto CV
2361 attached to the pad entry by magic. But shortly there-
2362 after 81df9f6f95 moved the magic to the pad name. The
2363 code here was never updated, so it wasn’t doing anything
2364 and got deleted when PADNAME became a distinct type. Is
2365 there any bug as a result? */
2366 if (CvOUTSIDE(innercv) == old_cv) {
2367 if (!CvWEAKOUTSIDE(innercv)) {
2368 SvREFCNT_dec(old_cv);
2369 SvREFCNT_inc_simple_void_NN(new_cv);
2371 CvOUTSIDE(innercv) = new_cv;
2374 else { /* format reference */
2375 SV * const rv = curpad[ix];
2377 if (!SvOK(rv)) continue;
2379 assert(SvWEAKREF(rv));
2380 innercv = (CV *)SvRV(rv);
2381 assert(!CvWEAKOUTSIDE(innercv));
2382 assert(CvOUTSIDE(innercv) == old_cv);
2383 SvREFCNT_dec(CvOUTSIDE(innercv));
2384 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2391 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2393 Push a new pad frame onto the padlist, unless there's already a pad at
2394 this depth, in which case don't bother creating a new one. Then give
2395 the new pad an C<@_> in slot zero.
2401 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2403 PERL_ARGS_ASSERT_PAD_PUSH;
2405 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2406 PAD** const svp = PadlistARRAY(padlist);
2407 AV* const newpad = newAV();
2408 SV** const oldpad = AvARRAY(svp[depth-1]);
2409 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2410 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2411 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2414 for ( ;ix > 0; ix--) {
2415 if (names_fill >= ix && PadnameLEN(names[ix])) {
2416 const char sigil = PadnamePV(names[ix])[0];
2417 if (PadnameOUTER(names[ix])
2418 || PadnameIsSTATE(names[ix])
2421 /* outer lexical or anon code */
2422 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2424 else { /* our own lexical */
2427 sv = MUTABLE_SV(newAV());
2428 else if (sigil == '%')
2429 sv = MUTABLE_SV(newHV());
2432 av_store(newpad, ix, sv);
2435 else if (PadnamePV(names[ix])) {
2436 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2439 /* save temporaries on recursion? */
2440 SV * const sv = newSV(0);
2441 av_store(newpad, ix, sv);
2446 av_store(newpad, 0, MUTABLE_SV(av));
2449 padlist_store(padlist, depth, newpad);
2453 #if defined(USE_ITHREADS)
2455 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2458 =for apidoc padlist_dup
2466 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2472 PERL_ARGS_ASSERT_PADLIST_DUP;
2474 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2475 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2477 max = cloneall ? PadlistMAX(srcpad) : 1;
2479 Newx(dstpad, 1, PADLIST);
2480 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2481 PadlistMAX(dstpad) = max;
2482 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2484 PadlistARRAY(dstpad)[0] = (PAD *)
2485 padnamelist_dup(PadlistNAMES(srcpad), param);
2486 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2489 for (depth = 1; depth <= max; ++depth)
2490 PadlistARRAY(dstpad)[depth] =
2491 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2493 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2494 to build anything other than the first level of pads. */
2495 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2497 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2498 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2499 SV **oldpad = AvARRAY(srcpad1);
2500 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2506 av_extend(pad1, ix);
2507 PadlistARRAY(dstpad)[1] = pad1;
2508 pad1a = AvARRAY(pad1);
2513 for ( ;ix > 0; ix--) {
2516 } else if (names_fill >= ix && names[ix] &&
2517 PadnameLEN(names[ix])) {
2518 const char sigil = PadnamePV(names[ix])[0];
2519 if (PadnameOUTER(names[ix])
2520 || PadnameIsSTATE(names[ix])
2523 /* outer lexical or anon code */
2524 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2526 else { /* our own lexical */
2527 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2528 /* This is a work around for how the current
2529 implementation of ?{ } blocks in regexps
2530 interacts with lexicals. */
2531 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2536 sv = MUTABLE_SV(newAV());
2537 else if (sigil == '%')
2538 sv = MUTABLE_SV(newHV());
2545 else if (( names_fill >= ix && names[ix]
2546 && PadnamePV(names[ix]) )) {
2547 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2550 /* save temporaries on recursion? */
2551 SV * const sv = newSV(0);
2554 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2555 FIXTHAT before merging this branch.
2556 (And I know how to) */
2557 if (SvPADTMP(oldpad[ix]))
2563 args = newAV(); /* Will be @_ */
2565 pad1a[0] = (SV *)args;
2573 #endif /* USE_ITHREADS */
2576 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2579 SSize_t const oldmax = PadlistMAX(padlist);
2581 PERL_ARGS_ASSERT_PADLIST_STORE;
2585 if (key > PadlistMAX(padlist)) {
2586 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2587 (SV ***)&PadlistARRAY(padlist),
2588 (SV ***)&PadlistARRAY(padlist));
2589 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2592 ary = PadlistARRAY(padlist);
2593 SvREFCNT_dec(ary[key]);
2599 =for apidoc newPADNAMELIST
2601 Creates a new pad name list. C<max> is the highest index for which space
2608 Perl_newPADNAMELIST(size_t max)
2611 Newx(pnl, 1, PADNAMELIST);
2612 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2613 PadnamelistMAX(pnl) = -1;
2614 PadnamelistREFCNT(pnl) = 1;
2615 PadnamelistMAXNAMED(pnl) = 0;
2616 pnl->xpadnl_max = max;
2621 =for apidoc padnamelist_store
2623 Stores the pad name (which may be null) at the given index, freeing any
2624 existing pad name in that slot.
2630 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2634 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2638 if (key > pnl->xpadnl_max)
2639 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2640 (SV ***)&PadnamelistARRAY(pnl),
2641 (SV ***)&PadnamelistARRAY(pnl));
2642 if (PadnamelistMAX(pnl) < key) {
2643 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2644 key-PadnamelistMAX(pnl), PADNAME *);
2645 PadnamelistMAX(pnl) = key;
2647 ary = PadnamelistARRAY(pnl);
2649 PadnameREFCNT_dec(ary[key]);
2655 =for apidoc padnamelist_fetch
2657 Fetches the pad name from the given index.
2663 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2665 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2668 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2672 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2674 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2675 if (!--PadnamelistREFCNT(pnl)) {
2676 while(PadnamelistMAX(pnl) >= 0)
2678 PADNAME * const pn =
2679 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2681 PadnameREFCNT_dec(pn);
2683 Safefree(PadnamelistARRAY(pnl));
2688 #if defined(USE_ITHREADS)
2691 =for apidoc padnamelist_dup
2693 Duplicates a pad name list.
2699 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2701 PADNAMELIST *dstpad;
2702 SSize_t max = PadnamelistMAX(srcpad);
2704 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2706 /* look for it in the table first */
2707 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2711 dstpad = newPADNAMELIST(max);
2712 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2713 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2714 PadnamelistMAX(dstpad) = max;
2716 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2717 for (; max >= 0; max--)
2718 if (PadnamelistARRAY(srcpad)[max]) {
2719 PadnamelistARRAY(dstpad)[max] =
2720 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2721 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2727 #endif /* USE_ITHREADS */
2730 =for apidoc newPADNAMEpvn
2732 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2733 use this for pad names that point to outer lexicals. See
2734 C<L</newPADNAMEouter>>.
2740 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2742 struct padname_with_str *alloc;
2743 char *alloc2; /* for Newxz */
2745 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2747 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2749 alloc = (struct padname_with_str *)alloc2;
2750 pn = (PADNAME *)alloc;
2751 PadnameREFCNT(pn) = 1;
2752 PadnamePV(pn) = alloc->xpadn_str;
2753 Copy(s, PadnamePV(pn), len, char);
2754 *(PadnamePV(pn) + len) = '\0';
2755 PadnameLEN(pn) = len;
2760 =for apidoc newPADNAMEouter
2762 Constructs and returns a new pad name. Only use this function for names
2763 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2764 the outer pad name that this one mirrors. The returned pad name has the
2765 C<PADNAMEt_OUTER> flag already set.
2771 Perl_newPADNAMEouter(PADNAME *outer)
2774 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2775 Newxz(pn, 1, PADNAME);
2776 PadnameREFCNT(pn) = 1;
2777 PadnamePV(pn) = PadnamePV(outer);
2778 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2779 another entry. The original pad name owns the buffer. */
2780 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2781 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2782 PadnameLEN(pn) = PadnameLEN(outer);
2787 Perl_padname_free(pTHX_ PADNAME *pn)
2789 PERL_ARGS_ASSERT_PADNAME_FREE;
2790 if (!--PadnameREFCNT(pn)) {
2791 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2792 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2795 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2796 SvREFCNT_dec(PadnameOURSTASH(pn));
2797 if (PadnameOUTER(pn))
2798 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2803 #if defined(USE_ITHREADS)
2806 =for apidoc padname_dup
2808 Duplicates a pad name.
2814 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2818 PERL_ARGS_ASSERT_PADNAME_DUP;
2820 /* look for it in the table first */
2821 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2825 if (!PadnamePV(src)) {
2826 dst = &PL_padname_undef;
2827 ptr_table_store(PL_ptr_table, src, dst);
2831 dst = PadnameOUTER(src)
2832 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2833 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2834 ptr_table_store(PL_ptr_table, src, dst);
2835 PadnameLEN(dst) = PadnameLEN(src);
2836 PadnameFLAGS(dst) = PadnameFLAGS(src);
2837 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2838 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2839 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2841 dst->xpadn_low = src->xpadn_low;
2842 dst->xpadn_high = src->xpadn_high;
2843 dst->xpadn_gen = src->xpadn_gen;
2847 #endif /* USE_ITHREADS */
2850 * ex: set ts=8 sts=4 sw=4 et: