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]);
398 U32 inner_rc = SvREFCNT(innercv);
400 assert(SvTYPE(innercv) != SVt_PVFM);
402 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
404 SvREFCNT_dec_NN(innercv);
408 /* in use, not just a prototype */
409 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
410 && (CvOUTSIDE(innercv) == cv))
412 assert(CvWEAKOUTSIDE(innercv));
413 /* don't relink to grandfather if he's being freed */
414 if (outercv && SvREFCNT(outercv)) {
415 CvWEAKOUTSIDE_off(innercv);
416 CvOUTSIDE(innercv) = outercv;
417 CvOUTSIDE_SEQ(innercv) = seq;
418 SvREFCNT_inc_simple_void_NN(outercv);
421 CvOUTSIDE(innercv) = NULL;
428 ix = PadlistMAX(padlist);
430 PAD * const sv = PadlistARRAY(padlist)[ix--];
432 if (sv == PL_comppad) {
440 PADNAMELIST * const names = PadlistNAMES(padlist);
441 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
442 PL_comppad_name = NULL;
443 PadnamelistREFCNT_dec(names);
445 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
447 CvPADLIST_set(&cvbody, NULL);
449 else if (CvISXSUB(&cvbody))
450 CvHSCXT(&cvbody) = NULL;
451 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
454 /* remove CvOUTSIDE unless this is an undef rather than a free */
456 CV * outside = CvOUTSIDE(&cvbody);
458 CvOUTSIDE(&cvbody) = NULL;
459 if (!CvWEAKOUTSIDE(&cvbody))
460 SvREFCNT_dec_NN(outside);
463 if (CvCONST(&cvbody)) {
464 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
465 /* CvCONST_off(cv); *//* turned off below */
467 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
468 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
469 * LEXICAL, which are used to determine the sub's name. */
470 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
475 =for apidoc cv_forget_slab
477 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
478 for making sure it is freed. (Hence, no two CVs should ever have a
479 reference count on the same slab.) The CV only needs to reference the slab
480 during compilation. Once it is compiled and C<CvROOT> attached, it has
481 finished its job, so it can forget the slab.
487 Perl_cv_forget_slab(pTHX_ CV *cv)
494 slabbed = cBOOL(CvSLABBED(cv));
495 if (!slabbed) return;
499 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
500 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
502 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
506 #ifdef PERL_DEBUG_READONLY_OPS
507 const size_t refcnt = slab->opslab_refcnt;
509 OpslabREFCNT_dec(slab);
510 #ifdef PERL_DEBUG_READONLY_OPS
511 if (refcnt > 1) Slab_to_ro(slab);
517 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
519 Allocates a place in the currently-compiling
520 pad (via L<perlapi/pad_alloc>) and
521 then stores a name for that entry. C<name> is adopted and
522 becomes the name entry; it must already contain the name
523 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
524 flag get added to C<name>. None of the other
525 processing of L<perlapi/pad_add_name_pvn>
526 is done. Returns the offset of the allocated pad slot.
532 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
535 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
537 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
539 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
542 SvPAD_TYPED_on(name);
544 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
548 SvOURSTASH_set(name, ourstash);
549 SvREFCNT_inc_simple_void_NN(ourstash);
551 else if (flags & padadd_STATE) {
552 SvPAD_STATE_on(name);
555 padnamelist_store(PL_comppad_name, offset, name);
556 if (PadnameLEN(name) > 1)
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 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
570 If C<typestash> is non-null, the name is for a typed lexical, and this
571 identifies the type. If C<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)
589 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
591 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
592 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
595 name = newPADNAMEpvn(namepv, namelen);
597 if ((flags & padadd_NO_DUP_CHECK) == 0) {
599 SAVEFREEPADNAME(name); /* in case of fatal warnings */
600 /* check for duplicate declaration */
601 pad_check_dup(name, flags & padadd_OUR, ourstash);
602 PadnameREFCNT(name)++;
606 offset = pad_alloc_name(name, flags, typestash, ourstash);
608 /* not yet introduced */
609 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
610 COP_SEQ_RANGE_HIGH_set(name, 0);
612 if (!PL_min_intro_pending)
613 PL_min_intro_pending = offset;
614 PL_max_intro_pending = offset;
615 /* if it's not a simple scalar, replace with an AV or HV */
616 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
617 assert(SvREFCNT(PL_curpad[offset]) == 1);
618 if (namelen != 0 && *namepv == '@')
619 sv_upgrade(PL_curpad[offset], SVt_PVAV);
620 else if (namelen != 0 && *namepv == '%')
621 sv_upgrade(PL_curpad[offset], SVt_PVHV);
622 else if (namelen != 0 && *namepv == '&')
623 sv_upgrade(PL_curpad[offset], SVt_PVCV);
624 assert(SvPADMY(PL_curpad[offset]));
625 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
626 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
627 (long)offset, PadnamePV(name),
628 PTR2UV(PL_curpad[offset])));
634 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
636 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
637 instead of a string/length pair.
643 Perl_pad_add_name_pv(pTHX_ const char *name,
644 const U32 flags, HV *typestash, HV *ourstash)
646 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
647 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
651 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
653 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
654 of an SV instead of a string/length pair.
660 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
664 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
665 namepv = SvPVutf8(name, namelen);
666 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
670 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
672 Allocates a place in the currently-compiling pad,
673 returning the offset of the allocated pad slot.
674 No name is initially attached to the pad slot.
675 C<tmptype> is a set of flags indicating the kind of pad entry required,
676 which will be set in the value SV for the allocated pad entry:
678 SVs_PADMY named lexical variable ("my", "our", "state")
679 SVs_PADTMP unnamed temporary store
680 SVf_READONLY constant shared between recursion levels
682 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
683 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
684 does not cause the SV in the pad slot to be marked read-only, but simply
685 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
686 least should be treated as such.
688 C<optype> should be an opcode indicating the type of operation that the
689 pad entry is to support. This doesn't affect operational semantics,
690 but is used for debugging.
696 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
701 PERL_UNUSED_ARG(optype);
702 ASSERT_CURPAD_ACTIVE("pad_alloc");
704 if (AvARRAY(PL_comppad) != PL_curpad)
705 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
706 AvARRAY(PL_comppad), PL_curpad);
707 if (PL_pad_reset_pending)
709 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
710 /* For a my, simply push a null SV onto the end of PL_comppad. */
711 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
712 retval = (PADOFFSET)AvFILLp(PL_comppad);
715 /* For a tmp, scan the pad from PL_padix upwards
716 * for a slot which has no name and no active value.
717 * For a constant, likewise, but use PL_constpadix.
719 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
720 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
721 const bool konst = cBOOL(tmptype & SVf_READONLY);
722 retval = konst ? PL_constpadix : PL_padix;
725 * Entries that close over unavailable variables
726 * in outer subs contain values not marked PADMY.
727 * Thus we must skip, not just pad values that are
728 * marked as current pad values, but also those with names.
729 * If pad_reset is enabled, ‘current’ means different
730 * things depending on whether we are allocating a con-
731 * stant or a target. For a target, things marked PADTMP
732 * can be reused; not so for constants.
735 if (++retval <= names_fill &&
736 (pn = names[retval]) && PadnamePV(pn))
738 sv = *av_fetch(PL_comppad, retval, TRUE);
741 (konst ? SVs_PADTMP : 0)
749 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
750 tmptype &= ~SVf_READONLY;
751 tmptype |= SVs_PADTMP;
753 *(konst ? &PL_constpadix : &PL_padix) = retval;
755 SvFLAGS(sv) |= tmptype;
756 PL_curpad = AvARRAY(PL_comppad);
758 DEBUG_X(PerlIO_printf(Perl_debug_log,
759 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
760 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
761 PL_op_name[optype]));
762 #ifdef DEBUG_LEAKING_SCALARS
763 sv->sv_debug_optype = optype;
764 sv->sv_debug_inpad = 1;
770 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
772 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
773 for an anonymous function that is lexically scoped inside the
774 currently-compiling function.
775 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
776 to the outer scope is weakened to avoid a reference loop.
778 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
780 C<optype> should be an opcode indicating the type of operation that the
781 pad entry is to support. This doesn't affect operational semantics,
782 but is used for debugging.
788 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
791 PADNAME * const name = newPADNAMEpvn("&", 1);
793 PERL_ARGS_ASSERT_PAD_ADD_ANON;
794 assert (SvTYPE(func) == SVt_PVCV);
797 /* These two aren't used; just make sure they're not equal to
798 * PERL_PADSEQ_INTRO. They should be 0 by default. */
799 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
800 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
801 ix = pad_alloc(optype, SVs_PADMY);
802 padnamelist_store(PL_comppad_name, ix, name);
803 av_store(PL_comppad, ix, (SV*)func);
805 /* to avoid ref loops, we never have parent + child referencing each
806 * other simultaneously */
807 if (CvOUTSIDE(func)) {
808 assert(!CvWEAKOUTSIDE(func));
809 CvWEAKOUTSIDE_on(func);
810 SvREFCNT_dec_NN(CvOUTSIDE(func));
816 Perl_pad_add_weakref(pTHX_ CV* func)
818 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
819 PADNAME * const name = newPADNAMEpvn("&", 1);
820 SV * const rv = newRV_inc((SV *)func);
822 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
824 /* These two aren't used; just make sure they're not equal to
825 * PERL_PADSEQ_INTRO. They should be 0 by default. */
826 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
827 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
828 padnamelist_store(PL_comppad_name, ix, name);
830 av_store(PL_comppad, ix, rv);
834 =for apidoc pad_check_dup
836 Check for duplicate declarations: report any of:
838 * a 'my' in the current scope with the same name;
839 * an 'our' (anywhere in the pad) with the same name and the
840 same stash as 'ourstash'
842 C<is_our> indicates that the name to check is an C<"our"> declaration.
848 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
852 const U32 is_our = flags & padadd_OUR;
854 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
856 ASSERT_CURPAD_ACTIVE("pad_check_dup");
858 assert((flags & ~padadd_OUR) == 0);
860 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
861 return; /* nothing to check */
863 svp = PadnamelistARRAY(PL_comppad_name);
864 top = PadnamelistMAX(PL_comppad_name);
865 /* check the current scope */
866 for (off = top; off > PL_comppad_name_floor; off--) {
867 PADNAME * const sv = svp[off];
869 && PadnameLEN(sv) == PadnameLEN(name)
871 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
872 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
873 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
875 if (is_our && (SvPAD_OUR(sv)))
876 break; /* "our" masking "our" */
877 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
878 Perl_warner(aTHX_ packWARN(WARN_MISC),
879 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
881 PL_parser->in_my == KEY_my ? "my" :
882 PL_parser->in_my == KEY_sigvar ? "my" :
884 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
886 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
887 ? "scope" : "statement"));
892 /* check the rest of the pad */
895 PADNAME * const sv = svp[off];
897 && PadnameLEN(sv) == PadnameLEN(name)
899 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
900 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
901 && SvOURSTASH(sv) == ourstash
902 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
904 Perl_warner(aTHX_ packWARN(WARN_MISC),
905 "\"our\" variable %" PNf " redeclared", PNfARG(sv));
906 if (off <= PL_comppad_name_floor)
907 Perl_warner(aTHX_ packWARN(WARN_MISC),
908 "\t(Did you mean \"local\" instead of \"our\"?)\n");
918 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
920 Given the name of a lexical variable, find its position in the
921 currently-compiling pad.
922 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
923 C<flags> is reserved and must be zero.
924 If it is not in the current pad but appears in the pad of any lexically
925 enclosing scope, then a pseudo-entry for it is added in the current pad.
926 Returns the offset in the current pad,
927 or C<NOT_IN_PAD> if no such lexical is in scope.
933 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
938 const PADNAMELIST *namelist;
941 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
943 pad_peg("pad_findmy_pvn");
946 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
949 /* compilation errors can zero PL_compcv */
953 offset = pad_findlex(namepv, namelen, flags,
954 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
955 if (offset != NOT_IN_PAD)
958 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
960 if (*namepv == '&') return NOT_IN_PAD;
962 /* look for an our that's being introduced; this allows
963 * our $foo = 0 unless defined $foo;
964 * to not give a warning. (Yes, this is a hack) */
966 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
967 name_p = PadnamelistARRAY(namelist);
968 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
969 const PADNAME * const name = name_p[offset];
970 if (name && PadnameLEN(name) == namelen
971 && !PadnameOUTER(name)
972 && (PadnameIsOUR(name))
973 && ( PadnamePV(name) == namepv
974 || memEQ(PadnamePV(name), namepv, namelen) )
975 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
983 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
985 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
986 instead of a string/length pair.
992 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
994 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
995 return pad_findmy_pvn(name, strlen(name), flags);
999 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1001 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1002 of an SV instead of a string/length pair.
1008 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1012 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1013 namepv = SvPVutf8(name, namelen);
1014 return pad_findmy_pvn(namepv, namelen, flags);
1018 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1020 Until the lexical C<$_> feature was removed, this function would
1021 find the position of the lexical C<$_> in the pad of the
1022 currently-executing function and returns the offset in the current pad,
1025 Now it always returns C<NOT_IN_PAD>.
1031 Perl_find_rundefsvoffset(pTHX)
1033 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1038 =for apidoc Am|SV *|find_rundefsv
1040 Returns the global variable C<$_>.
1046 Perl_find_rundefsv(pTHX)
1052 =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
1054 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1055 in the inner pads if it's found in an outer one.
1057 Returns the offset in the bottom pad of the lex or the fake lex.
1058 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1059 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1060 vars return values, and so are pointers to where the returned values
1061 should be stored. C<out_capture>, if non-null, requests that the innermost
1062 instance of the lexical is captured; C<out_name> is set to the innermost
1063 matched pad name or fake pad name; C<out_flags> returns the flags normally
1064 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1066 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1067 then comes back down, adding fake entries
1068 as it goes. It has to be this way
1069 because fake names in anon protoypes have to store in C<xpadn_low> the
1070 index into the parent pad.
1075 /* the CV has finished being compiled. This is not a sufficient test for
1076 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1077 #define CvCOMPILED(cv) CvROOT(cv)
1079 /* the CV does late binding of its lexicals */
1080 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1083 S_unavailable(pTHX_ PADNAME *name)
1085 /* diag_listed_as: Variable "%s" is not available */
1086 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1087 "%se \"%" PNf "\" is not available",
1088 *PadnamePV(name) == '&'
1095 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1096 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1098 PADOFFSET offset, new_offset;
1101 const PADLIST * const padlist = CvPADLIST(cv);
1102 const bool staleok = !!(flags & padadd_STALEOK);
1104 PERL_ARGS_ASSERT_PAD_FINDLEX;
1106 flags &= ~ padadd_STALEOK; /* one-shot flag */
1108 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1113 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1114 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1115 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1116 out_capture ? " capturing" : "" ));
1118 /* first, search this pad */
1120 if (padlist) { /* not an undef CV */
1121 PADOFFSET fake_offset = 0;
1122 const PADNAMELIST * const names = PadlistNAMES(padlist);
1123 PADNAME * const * const name_p = PadnamelistARRAY(names);
1125 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1126 const PADNAME * const name = name_p[offset];
1127 if (name && PadnameLEN(name) == namelen
1128 && ( PadnamePV(name) == namepv
1129 || memEQ(PadnamePV(name), namepv, namelen) ))
1131 if (PadnameOUTER(name)) {
1132 fake_offset = offset; /* in case we don't find a real one */
1135 if (PadnameIN_SCOPE(name, seq))
1140 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1141 if (offset > 0) { /* not fake */
1143 *out_name = name_p[offset]; /* return the name */
1145 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1146 * instances. For now, we just test !CvUNIQUE(cv), but
1147 * ideally, we should detect my's declared within loops
1148 * etc - this would allow a wider range of 'not stayed
1149 * shared' warnings. We also treated already-compiled
1150 * lexes as not multi as viewed from evals. */
1152 *out_flags = CvANON(cv) ?
1154 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1155 ? PAD_FAKELEX_MULTI : 0;
1157 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1158 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1159 PTR2UV(cv), (long)offset,
1160 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1161 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1163 else { /* fake match */
1164 offset = fake_offset;
1165 *out_name = name_p[offset]; /* return the name */
1166 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1167 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1168 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1169 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1170 (unsigned long) PARENT_PAD_INDEX(*out_name)
1174 /* return the lex? */
1179 if (PadnameIsOUR(*out_name)) {
1180 *out_capture = NULL;
1184 /* trying to capture from an anon prototype? */
1186 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1187 : *out_flags & PAD_FAKELEX_ANON)
1193 *out_capture = NULL;
1199 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1200 && !PadnameIsSTATE(name_p[offset])
1201 && warn && ckWARN(WARN_CLOSURE)) {
1203 /* diag_listed_as: Variable "%s" will not stay
1205 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1206 "%se \"%" UTF8f "\" will not stay shared",
1207 *namepv == '&' ? "Subroutin" : "Variabl",
1208 UTF8fARG(1, namelen, namepv));
1211 if (fake_offset && CvANON(cv)
1212 && CvCLONE(cv) &&!CvCLONED(cv))
1215 /* not yet caught - look further up */
1216 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1217 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1220 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1222 newwarn, out_capture, out_name, out_flags);
1227 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1228 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1229 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1230 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1231 PTR2UV(cv), PTR2UV(*out_capture)));
1233 if (SvPADSTALE(*out_capture)
1234 && (!CvDEPTH(cv) || !staleok)
1235 && !PadnameIsSTATE(name_p[offset]))
1239 *out_capture = NULL;
1242 if (!*out_capture) {
1243 if (namelen != 0 && *namepv == '@')
1244 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1245 else if (namelen != 0 && *namepv == '%')
1246 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1247 else if (namelen != 0 && *namepv == '&')
1248 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1250 *out_capture = sv_newmortal();
1258 /* it's not in this pad - try above */
1263 /* out_capture non-null means caller wants us to capture lex; in
1264 * addition we capture ourselves unless it's an ANON/format */
1265 new_capturep = out_capture ? out_capture :
1266 CvLATE(cv) ? NULL : &new_capture;
1268 offset = pad_findlex(namepv, namelen,
1269 flags | padadd_STALEOK*(new_capturep == &new_capture),
1270 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1271 new_capturep, out_name, out_flags);
1272 if (offset == NOT_IN_PAD)
1275 /* found in an outer CV. Add appropriate fake entry to this pad */
1277 /* don't add new fake entries (via eval) to CVs that we have already
1278 * finished compiling, or to undef CVs */
1279 if (CvCOMPILED(cv) || !padlist)
1280 return 0; /* this dummy (and invalid) value isnt used by the caller */
1283 PADNAME *new_name = newPADNAMEouter(*out_name);
1284 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1285 PAD * const ocomppad = PL_comppad;
1286 PL_comppad_name = PadlistNAMES(padlist);
1287 PL_comppad = PadlistARRAY(padlist)[1];
1288 PL_curpad = AvARRAY(PL_comppad);
1291 = pad_alloc_name(new_name,
1292 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1293 PadnameTYPE(*out_name),
1294 PadnameOURSTASH(*out_name)
1297 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1298 "Pad addname: %ld \"%.*s\" FAKE\n",
1300 (int) PadnameLEN(new_name),
1301 PadnamePV(new_name)));
1302 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1304 PARENT_PAD_INDEX_set(new_name, 0);
1305 if (PadnameIsOUR(new_name)) {
1306 NOOP; /* do nothing */
1308 else if (CvLATE(cv)) {
1309 /* delayed creation - just note the offset within parent pad */
1310 PARENT_PAD_INDEX_set(new_name, offset);
1314 /* immediate creation - capture outer value right now */
1315 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1316 /* But also note the offset, as newMYSUB needs it */
1317 PARENT_PAD_INDEX_set(new_name, offset);
1318 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1319 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1320 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1322 *out_name = new_name;
1323 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1325 PL_comppad_name = ocomppad_name;
1326 PL_comppad = ocomppad;
1327 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1335 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1337 Get the value at offset C<po> in the current (compiling or executing) pad.
1338 Use macro C<PAD_SV> instead of calling this function directly.
1344 Perl_pad_sv(pTHX_ PADOFFSET po)
1346 ASSERT_CURPAD_ACTIVE("pad_sv");
1349 Perl_croak(aTHX_ "panic: pad_sv po");
1350 DEBUG_X(PerlIO_printf(Perl_debug_log,
1351 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1352 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1354 return PL_curpad[po];
1358 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1360 Set the value at offset C<po> in the current (compiling or executing) pad.
1361 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1367 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1369 PERL_ARGS_ASSERT_PAD_SETSV;
1371 ASSERT_CURPAD_ACTIVE("pad_setsv");
1373 DEBUG_X(PerlIO_printf(Perl_debug_log,
1374 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1375 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1380 #endif /* DEBUGGING */
1383 =for apidoc m|void|pad_block_start|int full
1385 Update the pad compilation state variables on entry to a new block.
1391 Perl_pad_block_start(pTHX_ int full)
1393 ASSERT_CURPAD_ACTIVE("pad_block_start");
1394 save_strlen((STRLEN *)&PL_comppad_name_floor);
1395 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1397 PL_comppad_name_fill = PL_comppad_name_floor;
1398 if (PL_comppad_name_floor < 0)
1399 PL_comppad_name_floor = 0;
1400 save_strlen((STRLEN *)&PL_min_intro_pending);
1401 save_strlen((STRLEN *)&PL_max_intro_pending);
1402 PL_min_intro_pending = 0;
1403 save_strlen((STRLEN *)&PL_comppad_name_fill);
1404 save_strlen((STRLEN *)&PL_padix_floor);
1405 /* PL_padix_floor is what PL_padix is reset to at the start of each
1406 statement, by pad_reset(). We set it when entering a new scope
1407 to keep things like this working:
1408 print "$foo$bar", do { this(); that() . "foo" };
1409 We must not let "$foo$bar" and the later concatenation share the
1411 PL_padix_floor = PL_padix;
1412 PL_pad_reset_pending = FALSE;
1416 =for apidoc Am|U32|intro_my
1418 "Introduce" C<my> variables to visible status. This is called during parsing
1419 at the end of each statement to make lexical variables visible to subsequent
1432 ASSERT_CURPAD_ACTIVE("intro_my");
1433 if (PL_compiling.cop_seq) {
1434 seq = PL_compiling.cop_seq;
1435 PL_compiling.cop_seq = 0;
1438 seq = PL_cop_seqmax;
1439 if (! PL_min_intro_pending)
1442 svp = PadnamelistARRAY(PL_comppad_name);
1443 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1444 PADNAME * const sv = svp[i];
1446 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1447 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1449 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1450 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1451 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1452 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1453 (long)i, PadnamePV(sv),
1454 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1455 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1460 PL_min_intro_pending = 0;
1461 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1462 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1463 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1469 =for apidoc m|void|pad_leavemy
1471 Cleanup at end of scope during compilation: set the max seq number for
1472 lexicals in this scope and warn of any lexicals that never got introduced.
1478 Perl_pad_leavemy(pTHX)
1482 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1484 PL_pad_reset_pending = FALSE;
1486 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1487 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1488 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1489 const PADNAME * const name = svp[off];
1490 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1491 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1492 "%" PNf " never introduced",
1496 /* "Deintroduce" my variables that are leaving with this scope. */
1497 for (off = PadnamelistMAX(PL_comppad_name);
1498 off > PL_comppad_name_fill; off--) {
1499 PADNAME * const sv = svp[off];
1500 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1501 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1503 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1504 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1505 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1506 (long)off, PadnamePV(sv),
1507 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1508 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1510 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1511 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1512 OP *kid = newOP(OP_INTROCV, 0);
1514 o = op_prepend_elem(OP_LINESEQ, kid, o);
1519 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1520 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1525 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1527 Abandon the tmp in the current pad at offset C<po> and replace with a
1534 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1536 ASSERT_CURPAD_LEGAL("pad_swipe");
1539 if (AvARRAY(PL_comppad) != PL_curpad)
1540 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1541 AvARRAY(PL_comppad), PL_curpad);
1542 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1543 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1544 (long)po, (long)AvFILLp(PL_comppad));
1546 DEBUG_X(PerlIO_printf(Perl_debug_log,
1547 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1548 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1551 SvREFCNT_dec(PL_curpad[po]);
1554 /* if pad tmps aren't shared between ops, then there's no need to
1555 * create a new tmp when an existing op is freed */
1556 #ifdef USE_PAD_RESET
1557 PL_curpad[po] = newSV(0);
1558 SvPADTMP_on(PL_curpad[po]);
1560 PL_curpad[po] = NULL;
1562 if (PadnamelistMAX(PL_comppad_name) != -1
1563 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1564 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1565 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1567 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1569 /* Use PL_constpadix here, not PL_padix. The latter may have been
1570 reset by pad_reset. We don’t want pad_alloc to have to scan the
1571 whole pad when allocating a constant. */
1572 if (po < PL_constpadix)
1573 PL_constpadix = po - 1;
1577 =for apidoc m|void|pad_reset
1579 Mark all the current temporaries for reuse
1584 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1585 * between OPs from different statements. During compilation, at the start
1586 * of each statement pad_reset resets PL_padix back to its previous value.
1587 * When allocating a target, pad_alloc begins its scan through the pad at
1592 #ifdef USE_PAD_RESET
1593 if (AvARRAY(PL_comppad) != PL_curpad)
1594 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1595 AvARRAY(PL_comppad), PL_curpad);
1597 DEBUG_X(PerlIO_printf(Perl_debug_log,
1598 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1599 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1600 (long)PL_padix, (long)PL_padix_floor
1604 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1605 PL_padix = PL_padix_floor;
1608 PL_pad_reset_pending = FALSE;
1612 =for apidoc Amx|void|pad_tidy|padtidy_type type
1614 Tidy up a pad at the end of compilation of the code to which it belongs.
1615 Jobs performed here are: remove most stuff from the pads of anonsub
1616 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1617 the kind of subroutine:
1619 padtidy_SUB ordinary subroutine
1620 padtidy_SUBCLONE prototype for lexical closure
1621 padtidy_FORMAT format
1627 Perl_pad_tidy(pTHX_ padtidy_type type)
1631 ASSERT_CURPAD_ACTIVE("pad_tidy");
1633 /* If this CV has had any 'eval-capable' ops planted in it:
1634 * i.e. it contains any of:
1638 * * use re 'eval'; /$var/
1641 * Then any anon prototypes in the chain of CVs should be marked as
1642 * cloneable, so that for example the eval's CV in
1646 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1647 * potentially have an eval executed within it.
1650 if (PL_cv_has_eval || PL_perldb) {
1652 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1653 if (cv != PL_compcv && CvCOMPILED(cv))
1654 break; /* no need to mark already-compiled code */
1656 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1657 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1664 /* extend namepad to match curpad */
1665 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1666 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1668 if (type == padtidy_SUBCLONE) {
1669 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1672 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1674 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1677 * The only things that a clonable function needs in its
1678 * pad are anonymous subs, constants and GVs.
1679 * The rest are created anew during cloning.
1681 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1684 if (!(PadnamePV(namesv) &&
1685 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1687 SvREFCNT_dec(PL_curpad[ix]);
1688 PL_curpad[ix] = NULL;
1692 else if (type == padtidy_SUB) {
1693 AV * const av = newAV(); /* Will be @_ */
1694 av_store(PL_comppad, 0, MUTABLE_SV(av));
1698 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1699 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1701 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1702 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1703 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1705 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1706 /* This is a work around for how the current implementation of
1707 ?{ } blocks in regexps interacts with lexicals.
1709 One of our lexicals.
1710 Can't do this on all lexicals, otherwise sub baz() won't
1719 because completion of compiling &bar calling pad_tidy()
1720 would cause (top level) $foo to be marked as stale, and
1721 "no longer available". */
1722 SvPADSTALE_on(PL_curpad[ix]);
1726 PL_curpad = AvARRAY(PL_comppad);
1730 =for apidoc m|void|pad_free|PADOFFSET po
1732 Free the SV at offset po in the current pad.
1738 Perl_pad_free(pTHX_ PADOFFSET po)
1740 #ifndef USE_PAD_RESET
1743 ASSERT_CURPAD_LEGAL("pad_free");
1746 if (AvARRAY(PL_comppad) != PL_curpad)
1747 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1748 AvARRAY(PL_comppad), PL_curpad);
1750 Perl_croak(aTHX_ "panic: pad_free po");
1752 DEBUG_X(PerlIO_printf(Perl_debug_log,
1753 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1754 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1757 #ifndef USE_PAD_RESET
1759 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1760 SvFLAGS(sv) &= ~SVs_PADTMP;
1768 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1770 Dump the contents of a padlist
1776 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1778 const PADNAMELIST *pad_name;
1784 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1789 pad_name = PadlistNAMES(padlist);
1790 pad = PadlistARRAY(padlist)[1];
1791 pname = PadnamelistARRAY(pad_name);
1792 ppad = AvARRAY(pad);
1793 Perl_dump_indent(aTHX_ level, file,
1794 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1795 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1798 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1799 const PADNAME *namesv = pname[ix];
1800 if (namesv && !PadnameLEN(namesv)) {
1804 if (PadnameOUTER(namesv))
1805 Perl_dump_indent(aTHX_ level+1, file,
1806 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1809 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1811 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1812 (unsigned long)PARENT_PAD_INDEX(namesv)
1816 Perl_dump_indent(aTHX_ level+1, file,
1817 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1820 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1821 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1822 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1827 Perl_dump_indent(aTHX_ level+1, file,
1828 "%2d. 0x%" UVxf "<%lu>\n",
1831 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1840 =for apidoc m|void|cv_dump|CV *cv|const char *title
1842 dump the contents of a CV
1848 S_cv_dump(pTHX_ const CV *cv, const char *title)
1850 const CV * const outside = CvOUTSIDE(cv);
1851 PADLIST* const padlist = CvPADLIST(cv);
1853 PERL_ARGS_ASSERT_CV_DUMP;
1855 PerlIO_printf(Perl_debug_log,
1856 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1859 (CvANON(cv) ? "ANON"
1860 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1861 : (cv == PL_main_cv) ? "MAIN"
1862 : CvUNIQUE(cv) ? "UNIQUE"
1863 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1866 : CvANON(outside) ? "ANON"
1867 : (outside == PL_main_cv) ? "MAIN"
1868 : CvUNIQUE(outside) ? "UNIQUE"
1869 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1871 PerlIO_printf(Perl_debug_log,
1872 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1873 do_dump_pad(1, Perl_debug_log, padlist, 1);
1876 #endif /* DEBUGGING */
1879 =for apidoc Am|CV *|cv_clone|CV *proto
1881 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1882 of the function: its code, pad structure, and other attributes.
1883 The prototype is combined with a capture of outer lexicals to which the
1884 code refers, which are taken from the currently-executing instance of
1885 the immediately surrounding code.
1890 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1893 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1897 PADLIST* const protopadlist = CvPADLIST(proto);
1898 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1899 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1900 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1901 SV** const ppad = AvARRAY(protopad);
1902 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1903 const PADOFFSET fpad = AvFILLp(protopad);
1907 bool trouble = FALSE;
1909 assert(!CvUNIQUE(proto));
1911 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1912 * reliable. The currently-running sub is always the one we need to
1914 * For my subs, the currently-running sub may not be the one we want.
1915 * We have to check whether it is a clone of CvOUTSIDE.
1916 * Note that in general for formats, CvOUTSIDE != find_runcv.
1917 * Since formats may be nested inside closures, CvOUTSIDE may point
1918 * to a prototype; we instead want the cloned parent who called us.
1922 if (CvWEAKOUTSIDE(proto))
1923 outside = find_runcv(NULL);
1925 outside = CvOUTSIDE(proto);
1926 if ((CvCLONE(outside) && ! CvCLONED(outside))
1927 || !CvPADLIST(outside)
1928 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1929 outside = find_runcv_where(
1930 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1932 /* outside could be null */
1936 depth = outside ? CvDEPTH(outside) : 0;
1941 SAVESPTR(PL_compcv);
1943 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1946 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1948 SAVESPTR(PL_comppad_name);
1949 PL_comppad_name = protopad_name;
1950 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1951 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1953 av_fill(PL_comppad, fpad);
1955 PL_curpad = AvARRAY(PL_comppad);
1957 outpad = outside && CvPADLIST(outside)
1958 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1960 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1962 for (ix = fpad; ix > 0; ix--) {
1963 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1965 if (namesv && PadnameLEN(namesv)) { /* lexical */
1966 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1970 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1971 /* formats may have an inactive, or even undefined, parent;
1972 but state vars are always available. */
1973 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
1974 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
1975 && (!outside || !CvDEPTH(outside))) ) {
1976 S_unavailable(aTHX_ namesv);
1980 SvREFCNT_inc_simple_void_NN(sv);
1983 const char sigil = PadnamePV(namesv)[0];
1985 /* If there are state subs, we need to clone them, too.
1986 But they may need to close over variables we have
1987 not cloned yet. So we will have to do a second
1988 pass. Furthermore, there may be state subs clos-
1989 ing over other state subs’ entries, so we have
1990 to put a stub here and then clone into it on the
1992 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
1993 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
1995 if (CvOUTSIDE(ppad[ix]) != proto)
1997 sv = newSV_type(SVt_PVCV);
2000 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2003 /* Just provide a stub, but name it. It will be
2004 upgrade to the real thing on scope entry. */
2007 PERL_HASH(hash, PadnamePV(namesv)+1,
2008 PadnameLEN(namesv) - 1);
2009 sv = newSV_type(SVt_PVCV);
2012 share_hek(PadnamePV(namesv)+1,
2013 1 - PadnameLEN(namesv),
2018 else sv = SvREFCNT_inc(ppad[ix]);
2019 else if (sigil == '@')
2020 sv = MUTABLE_SV(newAV());
2021 else if (sigil == '%')
2022 sv = MUTABLE_SV(newHV());
2025 /* reset the 'assign only once' flag on each state var */
2026 if (sigil != '&' && SvPAD_STATE(namesv))
2031 else if (namesv && PadnamePV(namesv)) {
2032 sv = SvREFCNT_inc_NN(ppad[ix]);
2043 if (trouble || cloned) {
2044 /* Uh-oh, we have trouble! At least one of the state subs here
2045 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2046 could be pointing to another state protosub that we are
2047 about to clone. So we have to track which sub clones come
2048 from which protosubs. If the CvOUTSIDE pointer for a parti-
2049 cular sub points to something we have not cloned yet, we
2050 delay cloning it. We must loop through the pad entries,
2051 until we get a full pass with no cloning. If any uncloned
2052 subs remain (probably nested inside anonymous or ‘my’ subs),
2053 then they get cloned in a final pass.
2055 bool cloned_in_this_pass;
2057 cloned = (HV *)sv_2mortal((SV *)newHV());
2059 cloned_in_this_pass = FALSE;
2060 for (ix = fpad; ix > 0; ix--) {
2061 PADNAME * const name =
2062 (ix <= fname) ? pname[ix] : NULL;
2063 if (name && name != &PL_padname_undef
2064 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2065 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2067 CV * const protokey = CvOUTSIDE(ppad[ix]);
2068 CV ** const cvp = protokey == proto
2070 : (CV **)hv_fetch(cloned, (char *)&protokey,
2073 S_cv_clone(aTHX_ (CV *)ppad[ix],
2074 (CV *)PL_curpad[ix],
2076 (void)hv_store(cloned, (char *)&ppad[ix],
2078 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2081 cloned_in_this_pass = TRUE;
2085 } while (cloned_in_this_pass);
2087 for (ix = fpad; ix > 0; ix--) {
2088 PADNAME * const name =
2089 (ix <= fname) ? pname[ix] : NULL;
2090 if (name && name != &PL_padname_undef
2091 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2092 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2093 S_cv_clone(aTHX_ (CV *)ppad[ix],
2094 (CV *)PL_curpad[ix],
2095 CvOUTSIDE(ppad[ix]), cloned);
2098 else for (ix = fpad; ix > 0; ix--) {
2099 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2100 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2101 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2102 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2107 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2111 /* Constant sub () { $x } closing over $x:
2112 * The prototype was marked as a candiate for const-ization,
2113 * so try to grab the current const value, and if successful,
2114 * turn into a const sub:
2117 OP *o = CvSTART(cv);
2119 for (; o; o = o->op_next)
2120 if (o->op_type == OP_PADSV)
2122 ASSUME(o->op_type == OP_PADSV);
2123 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2124 /* the candidate should have 1 ref from this pad and 1 ref
2125 * from the parent */
2126 if (const_sv && SvREFCNT(const_sv) == 2) {
2127 const bool was_method = cBOOL(CvMETHOD(cv));
2128 bool copied = FALSE;
2130 PADNAME * const pn =
2131 PadlistNAMESARRAY(CvPADLIST(outside))
2132 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2133 CvPADLIST(cv))[o->op_targ])];
2134 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2136 if (PadnameLVALUE(pn)) {
2137 /* We have a lexical that is potentially modifiable
2138 elsewhere, so making a constant will break clo-
2139 sure behaviour. If this is a ‘simple lexical
2140 op tree’, i.e., sub(){$x}, emit a deprecation
2141 warning, but continue to exhibit the old behav-
2142 iour of making it a constant based on the ref-
2143 count of the candidate variable.
2145 A simple lexical op tree looks like this:
2153 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2157 Perl_ck_warner_d(aTHX_
2158 packWARN(WARN_DEPRECATED),
2159 "Constants from lexical "
2160 "variables potentially "
2161 "modified elsewhere are "
2162 "deprecated. This will not "
2163 "be allowed in Perl 5.32");
2164 /* We *copy* the lexical variable, and donate the
2165 copy to newCONSTSUB. Yes, this is ugly, and
2166 should be killed. We need to do this for the
2167 time being, however, because turning on SvPADTMP
2168 on a lexical will have observable effects
2170 const_sv = newSVsv(const_sv);
2178 SvREFCNT_inc_simple_void_NN(const_sv);
2179 /* If the lexical is not used elsewhere, it is safe to turn on
2180 SvPADTMP, since it is only when it is used in lvalue con-
2181 text that the difference is observable. */
2182 SvREADONLY_on(const_sv);
2183 SvPADTMP_on(const_sv);
2184 SvREFCNT_dec_NN(cv);
2185 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2199 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2204 const bool newcv = !cv;
2206 assert(!CvUNIQUE(proto));
2208 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2209 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2213 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2216 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2217 else CvGV_set(cv,CvGV(proto));
2218 CvSTASH_set(cv, CvSTASH(proto));
2220 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2222 CvSTART(cv) = CvSTART(proto);
2223 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2226 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2228 SvUTF8_on(MUTABLE_SV(cv));
2231 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2233 if (CvPADLIST(proto))
2234 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2237 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2238 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2239 cv_dump(proto, "Proto");
2247 Perl_cv_clone(pTHX_ CV *proto)
2249 PERL_ARGS_ASSERT_CV_CLONE;
2251 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2252 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2255 /* Called only by pp_clonecv */
2257 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2259 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2261 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2267 Returns an SV containing the name of the CV, mainly for use in error
2268 reporting. The CV may actually be a GV instead, in which case the returned
2269 SV holds the GV's name. Anything other than a GV or CV is treated as a
2270 string already holding the sub name, but this could change in the future.
2272 An SV may be passed as a second argument. If so, the name will be assigned
2273 to it and it will be returned. Otherwise the returned SV will be a new
2276 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2277 included. If the first argument is neither a CV nor a GV, this flag is
2278 ignored (subject to change).
2284 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2286 PERL_ARGS_ASSERT_CV_NAME;
2287 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2288 if (sv) sv_setsv(sv,(SV *)cv);
2289 return sv ? (sv) : (SV *)cv;
2292 SV * const retsv = sv ? (sv) : sv_newmortal();
2293 if (SvTYPE(cv) == SVt_PVCV) {
2295 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2296 sv_sethek(retsv, CvNAME_HEK(cv));
2298 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2299 sv_catpvs(retsv, "::");
2300 sv_cathek(retsv, CvNAME_HEK(cv));
2303 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2304 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2305 else gv_efullname3(retsv, CvGV(cv), NULL);
2307 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2308 else gv_efullname3(retsv,(GV *)cv,NULL);
2314 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2316 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2317 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2318 moved to a pre-existing CV struct.
2324 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2327 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2328 AV * const comppad = PadlistARRAY(padlist)[1];
2329 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2330 SV ** const curpad = AvARRAY(comppad);
2332 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2333 PERL_UNUSED_ARG(old_cv);
2335 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2336 const PADNAME *name = namepad[ix];
2337 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2338 && *PadnamePV(name) == '&')
2340 CV *innercv = MUTABLE_CV(curpad[ix]);
2341 if (UNLIKELY(PadnameOUTER(name))) {
2343 PADNAME **names = namepad;
2345 while (PadnameOUTER(name)) {
2346 assert(SvTYPE(cv) == SVt_PVCV);
2348 names = PadlistNAMESARRAY(CvPADLIST(cv));
2349 i = PARENT_PAD_INDEX(name);
2352 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2354 if (SvTYPE(innercv) == SVt_PVCV) {
2355 /* XXX 0afba48f added code here to check for a proto CV
2356 attached to the pad entry by magic. But shortly there-
2357 after 81df9f6f95 moved the magic to the pad name. The
2358 code here was never updated, so it wasn’t doing anything
2359 and got deleted when PADNAME became a distinct type. Is
2360 there any bug as a result? */
2361 if (CvOUTSIDE(innercv) == old_cv) {
2362 if (!CvWEAKOUTSIDE(innercv)) {
2363 SvREFCNT_dec(old_cv);
2364 SvREFCNT_inc_simple_void_NN(new_cv);
2366 CvOUTSIDE(innercv) = new_cv;
2369 else { /* format reference */
2370 SV * const rv = curpad[ix];
2372 if (!SvOK(rv)) continue;
2374 assert(SvWEAKREF(rv));
2375 innercv = (CV *)SvRV(rv);
2376 assert(!CvWEAKOUTSIDE(innercv));
2377 assert(CvOUTSIDE(innercv) == old_cv);
2378 SvREFCNT_dec(CvOUTSIDE(innercv));
2379 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2386 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2388 Push a new pad frame onto the padlist, unless there's already a pad at
2389 this depth, in which case don't bother creating a new one. Then give
2390 the new pad an C<@_> in slot zero.
2396 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2398 PERL_ARGS_ASSERT_PAD_PUSH;
2400 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2401 PAD** const svp = PadlistARRAY(padlist);
2402 AV* const newpad = newAV();
2403 SV** const oldpad = AvARRAY(svp[depth-1]);
2404 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2405 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2406 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2409 for ( ;ix > 0; ix--) {
2410 if (names_fill >= ix && PadnameLEN(names[ix])) {
2411 const char sigil = PadnamePV(names[ix])[0];
2412 if (PadnameOUTER(names[ix])
2413 || PadnameIsSTATE(names[ix])
2416 /* outer lexical or anon code */
2417 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2419 else { /* our own lexical */
2422 sv = MUTABLE_SV(newAV());
2423 else if (sigil == '%')
2424 sv = MUTABLE_SV(newHV());
2427 av_store(newpad, ix, sv);
2430 else if (PadnamePV(names[ix])) {
2431 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2434 /* save temporaries on recursion? */
2435 SV * const sv = newSV(0);
2436 av_store(newpad, ix, sv);
2441 av_store(newpad, 0, MUTABLE_SV(av));
2444 padlist_store(padlist, depth, newpad);
2448 #if defined(USE_ITHREADS)
2450 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2453 =for apidoc padlist_dup
2461 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2467 PERL_ARGS_ASSERT_PADLIST_DUP;
2469 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2470 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2472 max = cloneall ? PadlistMAX(srcpad) : 1;
2474 Newx(dstpad, 1, PADLIST);
2475 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2476 PadlistMAX(dstpad) = max;
2477 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2479 PadlistARRAY(dstpad)[0] = (PAD *)
2480 padnamelist_dup(PadlistNAMES(srcpad), param);
2481 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2484 for (depth = 1; depth <= max; ++depth)
2485 PadlistARRAY(dstpad)[depth] =
2486 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2488 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2489 to build anything other than the first level of pads. */
2490 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2492 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2493 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2494 SV **oldpad = AvARRAY(srcpad1);
2495 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2501 av_extend(pad1, ix);
2502 PadlistARRAY(dstpad)[1] = pad1;
2503 pad1a = AvARRAY(pad1);
2508 for ( ;ix > 0; ix--) {
2511 } else if (names_fill >= ix && names[ix] &&
2512 PadnameLEN(names[ix])) {
2513 const char sigil = PadnamePV(names[ix])[0];
2514 if (PadnameOUTER(names[ix])
2515 || PadnameIsSTATE(names[ix])
2518 /* outer lexical or anon code */
2519 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2521 else { /* our own lexical */
2522 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2523 /* This is a work around for how the current
2524 implementation of ?{ } blocks in regexps
2525 interacts with lexicals. */
2526 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2531 sv = MUTABLE_SV(newAV());
2532 else if (sigil == '%')
2533 sv = MUTABLE_SV(newHV());
2540 else if (( names_fill >= ix && names[ix]
2541 && PadnamePV(names[ix]) )) {
2542 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2545 /* save temporaries on recursion? */
2546 SV * const sv = newSV(0);
2549 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2550 FIXTHAT before merging this branch.
2551 (And I know how to) */
2552 if (SvPADTMP(oldpad[ix]))
2558 args = newAV(); /* Will be @_ */
2560 pad1a[0] = (SV *)args;
2568 #endif /* USE_ITHREADS */
2571 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2574 SSize_t const oldmax = PadlistMAX(padlist);
2576 PERL_ARGS_ASSERT_PADLIST_STORE;
2580 if (key > PadlistMAX(padlist)) {
2581 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2582 (SV ***)&PadlistARRAY(padlist),
2583 (SV ***)&PadlistARRAY(padlist));
2584 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2587 ary = PadlistARRAY(padlist);
2588 SvREFCNT_dec(ary[key]);
2594 =for apidoc newPADNAMELIST
2596 Creates a new pad name list. C<max> is the highest index for which space
2603 Perl_newPADNAMELIST(size_t max)
2606 Newx(pnl, 1, PADNAMELIST);
2607 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2608 PadnamelistMAX(pnl) = -1;
2609 PadnamelistREFCNT(pnl) = 1;
2610 PadnamelistMAXNAMED(pnl) = 0;
2611 pnl->xpadnl_max = max;
2616 =for apidoc padnamelist_store
2618 Stores the pad name (which may be null) at the given index, freeing any
2619 existing pad name in that slot.
2625 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2629 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2633 if (key > pnl->xpadnl_max)
2634 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2635 (SV ***)&PadnamelistARRAY(pnl),
2636 (SV ***)&PadnamelistARRAY(pnl));
2637 if (PadnamelistMAX(pnl) < key) {
2638 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2639 key-PadnamelistMAX(pnl), PADNAME *);
2640 PadnamelistMAX(pnl) = key;
2642 ary = PadnamelistARRAY(pnl);
2644 PadnameREFCNT_dec(ary[key]);
2650 =for apidoc padnamelist_fetch
2652 Fetches the pad name from the given index.
2658 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2660 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2663 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2667 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2669 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2670 if (!--PadnamelistREFCNT(pnl)) {
2671 while(PadnamelistMAX(pnl) >= 0)
2673 PADNAME * const pn =
2674 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2676 PadnameREFCNT_dec(pn);
2678 Safefree(PadnamelistARRAY(pnl));
2683 #if defined(USE_ITHREADS)
2686 =for apidoc padnamelist_dup
2688 Duplicates a pad name list.
2694 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2696 PADNAMELIST *dstpad;
2697 SSize_t max = PadnamelistMAX(srcpad);
2699 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2701 /* look for it in the table first */
2702 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2706 dstpad = newPADNAMELIST(max);
2707 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2708 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2709 PadnamelistMAX(dstpad) = max;
2711 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2712 for (; max >= 0; max--)
2713 if (PadnamelistARRAY(srcpad)[max]) {
2714 PadnamelistARRAY(dstpad)[max] =
2715 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2716 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2722 #endif /* USE_ITHREADS */
2725 =for apidoc newPADNAMEpvn
2727 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2728 use this for pad names that point to outer lexicals. See
2729 C<L</newPADNAMEouter>>.
2735 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2737 struct padname_with_str *alloc;
2738 char *alloc2; /* for Newxz */
2740 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2742 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2744 alloc = (struct padname_with_str *)alloc2;
2745 pn = (PADNAME *)alloc;
2746 PadnameREFCNT(pn) = 1;
2747 PadnamePV(pn) = alloc->xpadn_str;
2748 Copy(s, PadnamePV(pn), len, char);
2749 *(PadnamePV(pn) + len) = '\0';
2750 PadnameLEN(pn) = len;
2755 =for apidoc newPADNAMEouter
2757 Constructs and returns a new pad name. Only use this function for names
2758 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2759 the outer pad name that this one mirrors. The returned pad name has the
2760 C<PADNAMEt_OUTER> flag already set.
2766 Perl_newPADNAMEouter(PADNAME *outer)
2769 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2770 Newxz(pn, 1, PADNAME);
2771 PadnameREFCNT(pn) = 1;
2772 PadnamePV(pn) = PadnamePV(outer);
2773 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2774 another entry. The original pad name owns the buffer. */
2775 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2776 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2777 PadnameLEN(pn) = PadnameLEN(outer);
2782 Perl_padname_free(pTHX_ PADNAME *pn)
2784 PERL_ARGS_ASSERT_PADNAME_FREE;
2785 if (!--PadnameREFCNT(pn)) {
2786 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2787 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2790 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2791 SvREFCNT_dec(PadnameOURSTASH(pn));
2792 if (PadnameOUTER(pn))
2793 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2798 #if defined(USE_ITHREADS)
2801 =for apidoc padname_dup
2803 Duplicates a pad name.
2809 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2813 PERL_ARGS_ASSERT_PADNAME_DUP;
2815 /* look for it in the table first */
2816 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2820 if (!PadnamePV(src)) {
2821 dst = &PL_padname_undef;
2822 ptr_table_store(PL_ptr_table, src, dst);
2826 dst = PadnameOUTER(src)
2827 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2828 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2829 ptr_table_store(PL_ptr_table, src, dst);
2830 PadnameLEN(dst) = PadnameLEN(src);
2831 PadnameFLAGS(dst) = PadnameFLAGS(src);
2832 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2833 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2834 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2836 dst->xpadn_low = src->xpadn_low;
2837 dst->xpadn_high = src->xpadn_high;
2838 dst->xpadn_gen = src->xpadn_gen;
2842 #endif /* USE_ITHREADS */
2845 * ex: set ts=8 sts=4 sw=4 et: