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 =for apidoc_section 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 Amnh||SVs_PADSTALE
126 =for apidoc AmnxU|PADNAMELIST *|PL_comppad_name
128 During compilation, this points to the array containing the names part
129 of the pad for the currently-compiling code.
131 =for apidoc AmnxU|PAD *|PL_comppad
133 During compilation, this points to the array containing the values
134 part of the pad for the currently-compiling code. (At runtime a CV may
135 have many such value arrays; at compile time just one is constructed.)
136 At runtime, this points to the array containing the currently-relevant
137 values for the pad for the currently-executing code.
139 =for apidoc AmnxU|SV **|PL_curpad
141 Points directly to the body of the L</PL_comppad> array.
142 (I.e., this is C<PadARRAY(PL_comppad)>.)
149 #define PERL_IN_PAD_C
151 #include "keywords.h"
153 #define COP_SEQ_RANGE_LOW_set(sv,val) \
154 STMT_START { (sv)->xpadn_low = (val); } STMT_END
155 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
156 STMT_START { (sv)->xpadn_high = (val); } STMT_END
158 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
159 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
163 Perl_set_padlist(CV * cv, PADLIST *padlist){
164 PERL_ARGS_ASSERT_SET_PADLIST;
166 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
168 assert((Size_t)padlist != 0xEFEFEFEF);
170 # error unknown pointer size
172 assert(!CvISXSUB(cv));
173 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
180 Create a new padlist, updating the global variables for the
181 currently-compiling padlist to point to the new padlist. The following
182 flags can be OR'ed together:
184 padnew_CLONE this pad is for a cloned CV
185 padnew_SAVE save old globals on the save stack
186 padnew_SAVESUB also save extra stuff for start of sub
192 Perl_pad_new(pTHX_ int flags)
195 PADNAMELIST *padname;
199 ASSERT_CURPAD_LEGAL("pad_new");
201 /* save existing state, ... */
203 if (flags & padnew_SAVE) {
205 if (! (flags & padnew_CLONE)) {
206 SAVESPTR(PL_comppad_name);
207 save_strlen((STRLEN *)&PL_padix);
208 save_strlen((STRLEN *)&PL_constpadix);
209 save_strlen((STRLEN *)&PL_comppad_name_fill);
210 save_strlen((STRLEN *)&PL_min_intro_pending);
211 save_strlen((STRLEN *)&PL_max_intro_pending);
212 SAVEBOOL(PL_cv_has_eval);
213 if (flags & padnew_SAVESUB) {
214 SAVEBOOL(PL_pad_reset_pending);
219 /* ... create new pad ... */
221 Newxz(padlist, 1, PADLIST);
224 if (flags & padnew_CLONE) {
225 AV * const a0 = newAV(); /* will be @_ */
226 av_store(pad, 0, MUTABLE_SV(a0));
229 PadnamelistREFCNT(padname = PL_comppad_name)++;
232 padlist->xpadl_id = PL_padlist_generation++;
233 av_store(pad, 0, NULL);
234 padname = newPADNAMELIST(0);
235 padnamelist_store(padname, 0, &PL_padname_undef);
238 /* Most subroutines never recurse, hence only need 2 entries in the padlist
239 array - names, and depth=1. The default for av_store() is to allocate
240 0..3, and even an explicit call to av_extend() with <3 will be rounded
241 up, so we inline the allocation of the array here. */
243 PadlistMAX(padlist) = 1;
244 PadlistARRAY(padlist) = ary;
245 ary[0] = (PAD *)padname;
248 /* ... then update state variables */
251 PL_curpad = AvARRAY(pad);
253 if (! (flags & padnew_CLONE)) {
254 PL_comppad_name = padname;
255 PL_comppad_name_fill = 0;
256 PL_min_intro_pending = 0;
262 DEBUG_X(PerlIO_printf(Perl_debug_log,
263 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
264 " name=0x%" UVxf " flags=0x%" UVxf "\n",
265 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
266 PTR2UV(padname), (UV)flags
270 return (PADLIST*)padlist;
275 =for apidoc_section Embedding and Interpreter Cloning
279 Clear out all the active components of a CV. This can happen either
280 by an explicit C<undef &foo>, or by the reference count going to zero.
281 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
282 children can still follow the full lexical scope chain.
288 Perl_cv_undef(pTHX_ CV *cv)
290 PERL_ARGS_ASSERT_CV_UNDEF;
291 cv_undef_flags(cv, 0);
295 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
297 CV cvbody;/*CV body will never be realloced inside this func,
298 so dont read it more than once, use fake CV so existing macros
299 will work, the indirection and CV head struct optimized away*/
300 SvANY(&cvbody) = SvANY(cv);
302 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
304 DEBUG_X(PerlIO_printf(Perl_debug_log,
305 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
306 PTR2UV(cv), PTR2UV(PL_comppad))
309 if (CvFILE(&cvbody)) {
310 char * file = CvFILE(&cvbody);
311 CvFILE(&cvbody) = NULL;
312 if(CvDYNFILE(&cvbody))
316 /* CvSLABBED_off(&cvbody); *//* turned off below */
317 /* release the sub's body */
318 if (!CvISXSUB(&cvbody)) {
319 if(CvROOT(&cvbody)) {
320 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
321 if (CvDEPTHunsafe(&cvbody)) {
322 assert(SvTYPE(cv) == SVt_PVCV);
323 Perl_croak_nocontext("Can't undef active subroutine");
327 PAD_SAVE_SETNULLPAD();
329 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
330 op_free(CvROOT(&cvbody));
331 CvROOT(&cvbody) = NULL;
332 CvSTART(&cvbody) = NULL;
335 else if (CvSLABBED(&cvbody)) {
336 if( CvSTART(&cvbody)) {
338 PAD_SAVE_SETNULLPAD();
340 /* discard any leaked ops */
342 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
343 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
344 CvSTART(&cvbody) = NULL;
349 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
353 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
354 CvXSUB(&cvbody) = NULL;
356 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
357 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
358 if (!(flags & CV_UNDEF_KEEP_NAME)) {
359 if (CvNAMED(&cvbody)) {
360 CvNAME_HEK_set(&cvbody, NULL);
361 CvNAMED_off(&cvbody);
363 else CvGV_set(cv, NULL);
366 /* This statement and the subsequence if block was pad_undef(). */
367 pad_peg("pad_undef");
369 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
371 const PADLIST *padlist = CvPADLIST(&cvbody);
373 /* Free the padlist associated with a CV.
374 If parts of it happen to be current, we null the relevant PL_*pad*
375 global vars so that we don't have any dangling references left.
376 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
377 subs to the outer of this cv. */
379 DEBUG_X(PerlIO_printf(Perl_debug_log,
380 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
381 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
384 /* detach any '&' anon children in the pad; if afterwards they
385 * are still live, fix up their CvOUTSIDEs to point to our outside,
388 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
389 CV * const outercv = CvOUTSIDE(&cvbody);
390 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
391 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
392 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
393 PAD * const comppad = PadlistARRAY(padlist)[1];
394 SV ** const curpad = AvARRAY(comppad);
395 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
396 PADNAME * const name = namepad[ix];
397 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
399 CV * const innercv = MUTABLE_CV(curpad[ix]);
402 assert(SvTYPE(innercv) != SVt_PVFM);
403 inner_rc = SvREFCNT(innercv);
406 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
408 SvREFCNT_dec_NN(innercv);
412 /* in use, not just a prototype */
413 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
414 && (CvOUTSIDE(innercv) == cv))
416 assert(CvWEAKOUTSIDE(innercv));
417 /* don't relink to grandfather if he's being freed */
418 if (outercv && SvREFCNT(outercv)) {
419 CvWEAKOUTSIDE_off(innercv);
420 CvOUTSIDE(innercv) = outercv;
421 CvOUTSIDE_SEQ(innercv) = seq;
422 SvREFCNT_inc_simple_void_NN(outercv);
425 CvOUTSIDE(innercv) = NULL;
432 ix = PadlistMAX(padlist);
434 PAD * const sv = PadlistARRAY(padlist)[ix--];
436 if (sv == PL_comppad) {
444 PADNAMELIST * const names = PadlistNAMES(padlist);
445 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
446 PL_comppad_name = NULL;
447 PadnamelistREFCNT_dec(names);
449 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
451 CvPADLIST_set(&cvbody, NULL);
453 else if (CvISXSUB(&cvbody))
454 CvHSCXT(&cvbody) = NULL;
455 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
458 /* remove CvOUTSIDE unless this is an undef rather than a free */
460 CV * outside = CvOUTSIDE(&cvbody);
462 CvOUTSIDE(&cvbody) = NULL;
463 if (!CvWEAKOUTSIDE(&cvbody))
464 SvREFCNT_dec_NN(outside);
467 if (CvCONST(&cvbody)) {
468 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
469 /* CvCONST_off(cv); *//* turned off below */
471 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
472 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
473 * LEXICAL, which are used to determine the sub's name. */
474 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
479 =for apidoc cv_forget_slab
481 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
482 for making sure it is freed. (Hence, no two CVs should ever have a
483 reference count on the same slab.) The CV only needs to reference the slab
484 during compilation. Once it is compiled and C<CvROOT> attached, it has
485 finished its job, so it can forget the slab.
491 Perl_cv_forget_slab(pTHX_ CV *cv)
498 slabbed = cBOOL(CvSLABBED(cv));
499 if (!slabbed) return;
503 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
504 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
506 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
510 #ifdef PERL_DEBUG_READONLY_OPS
511 const size_t refcnt = slab->opslab_refcnt;
513 OpslabREFCNT_dec(slab);
514 #ifdef PERL_DEBUG_READONLY_OPS
515 if (refcnt > 1) Slab_to_ro(slab);
521 =for apidoc pad_alloc_name
523 Allocates a place in the currently-compiling
524 pad (via L<perlapi/pad_alloc>) and
525 then stores a name for that entry. C<name> is adopted and
526 becomes the name entry; it must already contain the name
527 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
528 flag get added to C<name>. None of the other
529 processing of L<perlapi/pad_add_name_pvn>
530 is done. Returns the offset of the allocated pad slot.
536 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
539 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
541 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
543 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
546 SvPAD_TYPED_on(name);
548 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
552 SvOURSTASH_set(name, ourstash);
553 SvREFCNT_inc_simple_void_NN(ourstash);
555 else if (flags & padadd_STATE) {
556 SvPAD_STATE_on(name);
559 padnamelist_store(PL_comppad_name, offset, name);
560 if (PadnameLEN(name) > 1)
561 PadnamelistMAXNAMED(PL_comppad_name) = offset;
566 =for apidoc pad_add_name_pvn
568 Allocates a place in the currently-compiling pad for a named lexical
569 variable. Stores the name and other metadata in the name part of the
570 pad, and makes preparations to manage the variable's lexical scoping.
571 Returns the offset of the allocated pad slot.
573 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
574 If C<typestash> is non-null, the name is for a typed lexical, and this
575 identifies the type. If C<ourstash> is non-null, it's a lexical reference
576 to a package variable, and this identifies the package. The following
577 flags can be OR'ed together:
579 padadd_OUR redundantly specifies if it's a package var
580 padadd_STATE variable will retain value persistently
581 padadd_NO_DUP_CHECK skip check for lexical shadowing
587 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
588 U32 flags, HV *typestash, HV *ourstash)
593 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
595 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
596 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
599 name = newPADNAMEpvn(namepv, namelen);
601 if ((flags & padadd_NO_DUP_CHECK) == 0) {
603 SAVEFREEPADNAME(name); /* in case of fatal warnings */
604 /* check for duplicate declaration */
605 pad_check_dup(name, flags & padadd_OUR, ourstash);
606 PadnameREFCNT(name)++;
610 offset = pad_alloc_name(name, flags, typestash, ourstash);
612 /* not yet introduced */
613 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
614 COP_SEQ_RANGE_HIGH_set(name, 0);
616 if (!PL_min_intro_pending)
617 PL_min_intro_pending = offset;
618 PL_max_intro_pending = offset;
619 /* if it's not a simple scalar, replace with an AV or HV */
620 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
621 assert(SvREFCNT(PL_curpad[offset]) == 1);
622 if (namelen != 0 && *namepv == '@')
623 sv_upgrade(PL_curpad[offset], SVt_PVAV);
624 else if (namelen != 0 && *namepv == '%')
625 sv_upgrade(PL_curpad[offset], SVt_PVHV);
626 else if (namelen != 0 && *namepv == '&')
627 sv_upgrade(PL_curpad[offset], SVt_PVCV);
628 assert(SvPADMY(PL_curpad[offset]));
629 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
630 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
631 (long)offset, PadnamePV(name),
632 PTR2UV(PL_curpad[offset])));
638 =for apidoc pad_add_name_pv
640 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
641 instead of a string/length pair.
647 Perl_pad_add_name_pv(pTHX_ const char *name,
648 const U32 flags, HV *typestash, HV *ourstash)
650 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
651 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
655 =for apidoc pad_add_name_sv
657 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
658 of an SV instead of a string/length pair.
664 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
668 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
669 namepv = SvPVutf8(name, namelen);
670 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
674 =for apidoc pad_alloc
676 Allocates a place in the currently-compiling pad,
677 returning the offset of the allocated pad slot.
678 No name is initially attached to the pad slot.
679 C<tmptype> is a set of flags indicating the kind of pad entry required,
680 which will be set in the value SV for the allocated pad entry:
682 SVs_PADMY named lexical variable ("my", "our", "state")
683 SVs_PADTMP unnamed temporary store
684 SVf_READONLY constant shared between recursion levels
686 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
687 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
688 does not cause the SV in the pad slot to be marked read-only, but simply
689 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
690 least should be treated as such.
692 C<optype> should be an opcode indicating the type of operation that the
693 pad entry is to support. This doesn't affect operational semantics,
694 but is used for debugging.
700 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
705 PERL_UNUSED_ARG(optype);
706 ASSERT_CURPAD_ACTIVE("pad_alloc");
708 if (AvARRAY(PL_comppad) != PL_curpad)
709 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
710 AvARRAY(PL_comppad), PL_curpad);
711 if (PL_pad_reset_pending)
713 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
714 /* For a my, simply push a null SV onto the end of PL_comppad. */
715 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
716 retval = (PADOFFSET)AvFILLp(PL_comppad);
719 /* For a tmp, scan the pad from PL_padix upwards
720 * for a slot which has no name and no active value.
721 * For a constant, likewise, but use PL_constpadix.
723 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
724 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
725 const bool konst = cBOOL(tmptype & SVf_READONLY);
726 retval = konst ? PL_constpadix : PL_padix;
729 * Entries that close over unavailable variables
730 * in outer subs contain values not marked PADMY.
731 * Thus we must skip, not just pad values that are
732 * marked as current pad values, but also those with names.
733 * If pad_reset is enabled, ‘current’ means different
734 * things depending on whether we are allocating a con-
735 * stant or a target. For a target, things marked PADTMP
736 * can be reused; not so for constants.
739 if (++retval <= names_fill &&
740 (pn = names[retval]) && PadnamePV(pn))
742 sv = *av_fetch(PL_comppad, retval, TRUE);
745 (konst ? SVs_PADTMP : 0)
753 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
754 tmptype &= ~SVf_READONLY;
755 tmptype |= SVs_PADTMP;
757 *(konst ? &PL_constpadix : &PL_padix) = retval;
759 SvFLAGS(sv) |= tmptype;
760 PL_curpad = AvARRAY(PL_comppad);
762 DEBUG_X(PerlIO_printf(Perl_debug_log,
763 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
764 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
765 PL_op_name[optype]));
766 #ifdef DEBUG_LEAKING_SCALARS
767 sv->sv_debug_optype = optype;
768 sv->sv_debug_inpad = 1;
774 =for apidoc pad_add_anon
776 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
777 for an anonymous function that is lexically scoped inside the
778 currently-compiling function.
779 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
780 to the outer scope is weakened to avoid a reference loop.
782 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
784 C<optype> should be an opcode indicating the type of operation that the
785 pad entry is to support. This doesn't affect operational semantics,
786 but is used for debugging.
792 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
795 PADNAME * const name = newPADNAMEpvn("&", 1);
797 PERL_ARGS_ASSERT_PAD_ADD_ANON;
798 assert (SvTYPE(func) == SVt_PVCV);
801 /* These two aren't used; just make sure they're not equal to
802 * PERL_PADSEQ_INTRO. They should be 0 by default. */
803 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
804 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
805 ix = pad_alloc(optype, SVs_PADMY);
806 padnamelist_store(PL_comppad_name, ix, name);
807 av_store(PL_comppad, ix, (SV*)func);
809 /* to avoid ref loops, we never have parent + child referencing each
810 * other simultaneously */
811 if (CvOUTSIDE(func)) {
812 assert(!CvWEAKOUTSIDE(func));
813 CvWEAKOUTSIDE_on(func);
814 SvREFCNT_dec_NN(CvOUTSIDE(func));
820 Perl_pad_add_weakref(pTHX_ CV* func)
822 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
823 PADNAME * const name = newPADNAMEpvn("&", 1);
824 SV * const rv = newRV_inc((SV *)func);
826 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
828 /* These two aren't used; just make sure they're not equal to
829 * PERL_PADSEQ_INTRO. They should be 0 by default. */
830 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
831 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
832 padnamelist_store(PL_comppad_name, ix, name);
834 av_store(PL_comppad, ix, rv);
838 =for apidoc pad_check_dup
840 Check for duplicate declarations: report any of:
842 * a 'my' in the current scope with the same name;
843 * an 'our' (anywhere in the pad) with the same name and the
844 same stash as 'ourstash'
846 C<is_our> indicates that the name to check is an C<"our"> declaration.
852 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
856 const U32 is_our = flags & padadd_OUR;
858 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
860 ASSERT_CURPAD_ACTIVE("pad_check_dup");
862 assert((flags & ~padadd_OUR) == 0);
864 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
865 return; /* nothing to check */
867 svp = PadnamelistARRAY(PL_comppad_name);
868 top = PadnamelistMAX(PL_comppad_name);
869 /* check the current scope */
870 for (off = top; off > PL_comppad_name_floor; off--) {
871 PADNAME * const sv = svp[off];
873 && PadnameLEN(sv) == PadnameLEN(name)
875 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
876 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
877 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
879 if (is_our && (SvPAD_OUR(sv)))
880 break; /* "our" masking "our" */
881 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
882 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
883 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
885 PL_parser->in_my == KEY_my ? "my" :
886 PL_parser->in_my == KEY_sigvar ? "my" :
888 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
890 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
891 ? "scope" : "statement"));
896 /* check the rest of the pad */
899 PADNAME * const sv = svp[off];
901 && PadnameLEN(sv) == PadnameLEN(name)
903 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
904 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
905 && SvOURSTASH(sv) == ourstash
906 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
908 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
909 "\"our\" variable %" PNf " redeclared", PNfARG(sv));
910 if (off <= PL_comppad_name_floor)
911 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
912 "\t(Did you mean \"local\" instead of \"our\"?)\n");
922 =for apidoc pad_findmy_pvn
924 Given the name of a lexical variable, find its position in the
925 currently-compiling pad.
926 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
927 C<flags> is reserved and must be zero.
928 If it is not in the current pad but appears in the pad of any lexically
929 enclosing scope, then a pseudo-entry for it is added in the current pad.
930 Returns the offset in the current pad,
931 or C<NOT_IN_PAD> if no such lexical is in scope.
937 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
942 const PADNAMELIST *namelist;
945 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
947 pad_peg("pad_findmy_pvn");
950 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
953 /* compilation errors can zero PL_compcv */
957 offset = pad_findlex(namepv, namelen, flags,
958 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
959 if (offset != NOT_IN_PAD)
962 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
964 if (*namepv == '&') return NOT_IN_PAD;
966 /* look for an our that's being introduced; this allows
967 * our $foo = 0 unless defined $foo;
968 * to not give a warning. (Yes, this is a hack) */
970 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
971 name_p = PadnamelistARRAY(namelist);
972 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
973 const PADNAME * const name = name_p[offset];
974 if (name && PadnameLEN(name) == namelen
975 && !PadnameOUTER(name)
976 && (PadnameIsOUR(name))
977 && ( PadnamePV(name) == namepv
978 || memEQ(PadnamePV(name), namepv, namelen) )
979 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
987 =for apidoc pad_findmy_pv
989 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
990 instead of a string/length pair.
996 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
998 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
999 return pad_findmy_pvn(name, strlen(name), flags);
1003 =for apidoc pad_findmy_sv
1005 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1006 of an SV instead of a string/length pair.
1012 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1016 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1017 namepv = SvPVutf8(name, namelen);
1018 return pad_findmy_pvn(namepv, namelen, flags);
1022 =for apidoc find_rundefsvoffset
1024 Until the lexical C<$_> feature was removed, this function would
1025 find the position of the lexical C<$_> in the pad of the
1026 currently-executing function and return the offset in the current pad,
1029 Now it always returns C<NOT_IN_PAD>.
1035 Perl_find_rundefsvoffset(pTHX)
1037 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1042 =for apidoc find_rundefsv
1044 Returns the global variable C<$_>.
1050 Perl_find_rundefsv(pTHX)
1056 =for apidoc pad_findlex
1058 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1059 in the inner pads if it's found in an outer one.
1061 Returns the offset in the bottom pad of the lex or the fake lex.
1062 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1063 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1064 vars return values, and so are pointers to where the returned values
1065 should be stored. C<out_capture>, if non-null, requests that the innermost
1066 instance of the lexical is captured; C<out_name> is set to the innermost
1067 matched pad name or fake pad name; C<out_flags> returns the flags normally
1068 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1070 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1071 then comes back down, adding fake entries
1072 as it goes. It has to be this way
1073 because fake names in anon prototypes have to store in C<xpadn_low> the
1074 index into the parent pad.
1079 /* the CV has finished being compiled. This is not a sufficient test for
1080 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1081 #define CvCOMPILED(cv) CvROOT(cv)
1083 /* the CV does late binding of its lexicals */
1084 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1087 S_unavailable(pTHX_ PADNAME *name)
1089 /* diag_listed_as: Variable "%s" is not available */
1090 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1091 "%s \"%" PNf "\" is not available",
1092 *PadnamePV(name) == '&'
1099 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1100 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1102 PADOFFSET offset, new_offset;
1105 const PADLIST * const padlist = CvPADLIST(cv);
1106 const bool staleok = !!(flags & padadd_STALEOK);
1108 PERL_ARGS_ASSERT_PAD_FINDLEX;
1110 flags &= ~ padadd_STALEOK; /* one-shot flag */
1112 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1117 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1118 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1119 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1120 out_capture ? " capturing" : "" ));
1122 /* first, search this pad */
1124 if (padlist) { /* not an undef CV */
1125 PADOFFSET fake_offset = 0;
1126 const PADNAMELIST * const names = PadlistNAMES(padlist);
1127 PADNAME * const * const name_p = PadnamelistARRAY(names);
1129 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1130 const PADNAME * const name = name_p[offset];
1131 if (name && PadnameLEN(name) == namelen
1132 && ( PadnamePV(name) == namepv
1133 || memEQ(PadnamePV(name), namepv, namelen) ))
1135 if (PadnameOUTER(name)) {
1136 fake_offset = offset; /* in case we don't find a real one */
1139 if (PadnameIN_SCOPE(name, seq))
1144 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1145 if (offset > 0) { /* not fake */
1147 *out_name = name_p[offset]; /* return the name */
1149 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1150 * instances. For now, we just test !CvUNIQUE(cv), but
1151 * ideally, we should detect my's declared within loops
1152 * etc - this would allow a wider range of 'not stayed
1153 * shared' warnings. We also treated already-compiled
1154 * lexes as not multi as viewed from evals. */
1156 *out_flags = CvANON(cv) ?
1158 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1159 ? PAD_FAKELEX_MULTI : 0;
1161 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1162 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1163 PTR2UV(cv), (long)offset,
1164 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1165 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1167 else { /* fake match */
1168 offset = fake_offset;
1169 *out_name = name_p[offset]; /* return the name */
1170 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1171 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1172 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1173 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1174 (unsigned long) PARENT_PAD_INDEX(*out_name)
1178 /* return the lex? */
1183 if (PadnameIsOUR(*out_name)) {
1184 *out_capture = NULL;
1188 /* trying to capture from an anon prototype? */
1190 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1191 : *out_flags & PAD_FAKELEX_ANON)
1197 *out_capture = NULL;
1203 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1204 && !PadnameIsSTATE(name_p[offset])
1205 && warn && ckWARN(WARN_CLOSURE)) {
1207 /* diag_listed_as: Variable "%s" will not stay
1209 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1210 "%s \"%" UTF8f "\" will not stay shared",
1211 *namepv == '&' ? "Subroutine" : "Variable",
1212 UTF8fARG(1, namelen, namepv));
1215 if (fake_offset && CvANON(cv)
1216 && CvCLONE(cv) &&!CvCLONED(cv))
1219 /* not yet caught - look further up */
1220 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1221 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1224 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1226 newwarn, out_capture, out_name, out_flags);
1231 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1232 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1233 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1234 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1235 PTR2UV(cv), PTR2UV(*out_capture)));
1237 if (SvPADSTALE(*out_capture)
1238 && (!CvDEPTH(cv) || !staleok)
1239 && !PadnameIsSTATE(name_p[offset]))
1243 *out_capture = NULL;
1246 if (!*out_capture) {
1247 if (namelen != 0 && *namepv == '@')
1248 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1249 else if (namelen != 0 && *namepv == '%')
1250 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1251 else if (namelen != 0 && *namepv == '&')
1252 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1254 *out_capture = sv_newmortal();
1262 /* it's not in this pad - try above */
1267 /* out_capture non-null means caller wants us to capture lex; in
1268 * addition we capture ourselves unless it's an ANON/format */
1269 new_capturep = out_capture ? out_capture :
1270 CvLATE(cv) ? NULL : &new_capture;
1272 offset = pad_findlex(namepv, namelen,
1273 flags | padadd_STALEOK*(new_capturep == &new_capture),
1274 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1275 new_capturep, out_name, out_flags);
1276 if (offset == NOT_IN_PAD)
1279 /* found in an outer CV. Add appropriate fake entry to this pad */
1281 /* don't add new fake entries (via eval) to CVs that we have already
1282 * finished compiling, or to undef CVs */
1283 if (CvCOMPILED(cv) || !padlist)
1284 return 0; /* this dummy (and invalid) value isnt used by the caller */
1287 PADNAME *new_name = newPADNAMEouter(*out_name);
1288 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1289 PAD * const ocomppad = PL_comppad;
1290 PL_comppad_name = PadlistNAMES(padlist);
1291 PL_comppad = PadlistARRAY(padlist)[1];
1292 PL_curpad = AvARRAY(PL_comppad);
1295 = pad_alloc_name(new_name,
1296 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1297 PadnameTYPE(*out_name),
1298 PadnameOURSTASH(*out_name)
1301 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1302 "Pad addname: %ld \"%.*s\" FAKE\n",
1304 (int) PadnameLEN(new_name),
1305 PadnamePV(new_name)));
1306 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1308 PARENT_PAD_INDEX_set(new_name, 0);
1309 if (PadnameIsOUR(new_name)) {
1310 NOOP; /* do nothing */
1312 else if (CvLATE(cv)) {
1313 /* delayed creation - just note the offset within parent pad */
1314 PARENT_PAD_INDEX_set(new_name, offset);
1318 /* immediate creation - capture outer value right now */
1319 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1320 /* But also note the offset, as newMYSUB needs it */
1321 PARENT_PAD_INDEX_set(new_name, offset);
1322 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1323 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1324 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1326 *out_name = new_name;
1327 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1329 PL_comppad_name = ocomppad_name;
1330 PL_comppad = ocomppad;
1331 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1341 Get the value at offset C<po> in the current (compiling or executing) pad.
1342 Use macro C<PAD_SV> instead of calling this function directly.
1348 Perl_pad_sv(pTHX_ PADOFFSET po)
1350 ASSERT_CURPAD_ACTIVE("pad_sv");
1353 Perl_croak(aTHX_ "panic: pad_sv po");
1354 DEBUG_X(PerlIO_printf(Perl_debug_log,
1355 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1356 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1358 return PL_curpad[po];
1362 =for apidoc pad_setsv
1364 Set the value at offset C<po> in the current (compiling or executing) pad.
1365 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1371 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1373 PERL_ARGS_ASSERT_PAD_SETSV;
1375 ASSERT_CURPAD_ACTIVE("pad_setsv");
1377 DEBUG_X(PerlIO_printf(Perl_debug_log,
1378 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1379 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1384 #endif /* DEBUGGING */
1387 =for apidoc pad_block_start
1389 Update the pad compilation state variables on entry to a new block.
1395 Perl_pad_block_start(pTHX_ int full)
1397 ASSERT_CURPAD_ACTIVE("pad_block_start");
1398 save_strlen((STRLEN *)&PL_comppad_name_floor);
1399 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1401 PL_comppad_name_fill = PL_comppad_name_floor;
1402 if (PL_comppad_name_floor < 0)
1403 PL_comppad_name_floor = 0;
1404 save_strlen((STRLEN *)&PL_min_intro_pending);
1405 save_strlen((STRLEN *)&PL_max_intro_pending);
1406 PL_min_intro_pending = 0;
1407 save_strlen((STRLEN *)&PL_comppad_name_fill);
1408 save_strlen((STRLEN *)&PL_padix_floor);
1409 /* PL_padix_floor is what PL_padix is reset to at the start of each
1410 statement, by pad_reset(). We set it when entering a new scope
1411 to keep things like this working:
1412 print "$foo$bar", do { this(); that() . "foo" };
1413 We must not let "$foo$bar" and the later concatenation share the
1415 PL_padix_floor = PL_padix;
1416 PL_pad_reset_pending = FALSE;
1420 =for apidoc intro_my
1422 "Introduce" C<my> variables to visible status. This is called during parsing
1423 at the end of each statement to make lexical variables visible to subsequent
1436 ASSERT_CURPAD_ACTIVE("intro_my");
1437 if (PL_compiling.cop_seq) {
1438 seq = PL_compiling.cop_seq;
1439 PL_compiling.cop_seq = 0;
1442 seq = PL_cop_seqmax;
1443 if (! PL_min_intro_pending)
1446 svp = PadnamelistARRAY(PL_comppad_name);
1447 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1448 PADNAME * const sv = svp[i];
1450 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1451 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1453 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1454 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1455 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1456 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1457 (long)i, PadnamePV(sv),
1458 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1459 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1464 PL_min_intro_pending = 0;
1465 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1466 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1467 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1473 =for apidoc pad_leavemy
1475 Cleanup at end of scope during compilation: set the max seq number for
1476 lexicals in this scope and warn of any lexicals that never got introduced.
1482 Perl_pad_leavemy(pTHX)
1486 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1488 PL_pad_reset_pending = FALSE;
1490 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1491 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1492 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1493 const PADNAME * const name = svp[off];
1494 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1495 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1496 "%" PNf " never introduced",
1500 /* "Deintroduce" my variables that are leaving with this scope. */
1501 for (off = PadnamelistMAX(PL_comppad_name);
1502 off > PL_comppad_name_fill; off--) {
1503 PADNAME * const sv = svp[off];
1504 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1505 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1507 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1508 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1509 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1510 (long)off, PadnamePV(sv),
1511 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1512 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1514 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1515 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1516 OP *kid = newOP(OP_INTROCV, 0);
1518 o = op_prepend_elem(OP_LINESEQ, kid, o);
1523 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1524 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1529 =for apidoc pad_swipe
1531 Abandon the tmp in the current pad at offset C<po> and replace with a
1538 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1540 ASSERT_CURPAD_LEGAL("pad_swipe");
1543 if (AvARRAY(PL_comppad) != PL_curpad)
1544 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1545 AvARRAY(PL_comppad), PL_curpad);
1546 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1547 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1548 (long)po, (long)AvFILLp(PL_comppad));
1550 DEBUG_X(PerlIO_printf(Perl_debug_log,
1551 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1552 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1555 SvREFCNT_dec(PL_curpad[po]);
1558 /* if pad tmps aren't shared between ops, then there's no need to
1559 * create a new tmp when an existing op is freed */
1560 #ifdef USE_PAD_RESET
1561 PL_curpad[po] = newSV(0);
1562 SvPADTMP_on(PL_curpad[po]);
1564 PL_curpad[po] = NULL;
1566 if (PadnamelistMAX(PL_comppad_name) != -1
1567 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1568 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1569 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1571 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1573 /* Use PL_constpadix here, not PL_padix. The latter may have been
1574 reset by pad_reset. We don’t want pad_alloc to have to scan the
1575 whole pad when allocating a constant. */
1576 if (po < PL_constpadix)
1577 PL_constpadix = po - 1;
1581 =for apidoc pad_reset
1583 Mark all the current temporaries for reuse
1588 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1589 * between OPs from different statements. During compilation, at the start
1590 * of each statement pad_reset resets PL_padix back to its previous value.
1591 * When allocating a target, pad_alloc begins its scan through the pad at
1596 #ifdef USE_PAD_RESET
1597 if (AvARRAY(PL_comppad) != PL_curpad)
1598 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1599 AvARRAY(PL_comppad), PL_curpad);
1601 DEBUG_X(PerlIO_printf(Perl_debug_log,
1602 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1603 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1604 (long)PL_padix, (long)PL_padix_floor
1608 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1609 PL_padix = PL_padix_floor;
1612 PL_pad_reset_pending = FALSE;
1616 =for apidoc pad_tidy
1618 Tidy up a pad at the end of compilation of the code to which it belongs.
1619 Jobs performed here are: remove most stuff from the pads of anonsub
1620 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1621 the kind of subroutine:
1623 padtidy_SUB ordinary subroutine
1624 padtidy_SUBCLONE prototype for lexical closure
1625 padtidy_FORMAT format
1631 Perl_pad_tidy(pTHX_ padtidy_type type)
1634 ASSERT_CURPAD_ACTIVE("pad_tidy");
1636 /* If this CV has had any 'eval-capable' ops planted in it:
1637 * i.e. it contains any of:
1641 * * use re 'eval'; /$var/
1644 * Then any anon prototypes in the chain of CVs should be marked as
1645 * cloneable, so that for example the eval's CV in
1649 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1650 * potentially have an eval executed within it.
1653 if (PL_cv_has_eval || PL_perldb) {
1655 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1656 if (cv != PL_compcv && CvCOMPILED(cv))
1657 break; /* no need to mark already-compiled code */
1659 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1660 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1667 /* extend namepad to match curpad */
1668 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1669 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1671 if (type == padtidy_SUBCLONE) {
1672 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1675 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1677 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1680 * The only things that a clonable function needs in its
1681 * pad are anonymous subs, constants and GVs.
1682 * The rest are created anew during cloning.
1684 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1687 if (!(PadnamePV(namesv) &&
1688 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1690 SvREFCNT_dec(PL_curpad[ix]);
1691 PL_curpad[ix] = NULL;
1695 else if (type == padtidy_SUB) {
1696 AV * const av = newAV(); /* Will be @_ */
1697 av_store(PL_comppad, 0, MUTABLE_SV(av));
1701 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1702 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1704 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1705 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1706 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1708 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1709 /* This is a work around for how the current implementation of
1710 ?{ } blocks in regexps interacts with lexicals.
1712 One of our lexicals.
1713 Can't do this on all lexicals, otherwise sub baz() won't
1722 because completion of compiling &bar calling pad_tidy()
1723 would cause (top level) $foo to be marked as stale, and
1724 "no longer available". */
1725 SvPADSTALE_on(PL_curpad[ix]);
1729 PL_curpad = AvARRAY(PL_comppad);
1733 =for apidoc pad_free
1735 Free the SV at offset po in the current pad.
1741 Perl_pad_free(pTHX_ PADOFFSET po)
1743 #ifndef USE_PAD_RESET
1746 ASSERT_CURPAD_LEGAL("pad_free");
1749 if (AvARRAY(PL_comppad) != PL_curpad)
1750 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1751 AvARRAY(PL_comppad), PL_curpad);
1753 Perl_croak(aTHX_ "panic: pad_free po");
1755 DEBUG_X(PerlIO_printf(Perl_debug_log,
1756 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1757 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1760 #ifndef USE_PAD_RESET
1762 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1763 SvFLAGS(sv) &= ~SVs_PADTMP;
1771 =for apidoc do_dump_pad
1773 Dump the contents of a padlist
1779 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1781 const PADNAMELIST *pad_name;
1787 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1792 pad_name = PadlistNAMES(padlist);
1793 pad = PadlistARRAY(padlist)[1];
1794 pname = PadnamelistARRAY(pad_name);
1795 ppad = AvARRAY(pad);
1796 Perl_dump_indent(aTHX_ level, file,
1797 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1798 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1801 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1802 const PADNAME *namesv = pname[ix];
1803 if (namesv && !PadnameLEN(namesv)) {
1807 if (PadnameOUTER(namesv))
1808 Perl_dump_indent(aTHX_ level+1, file,
1809 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1812 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1814 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1815 (unsigned long)PARENT_PAD_INDEX(namesv)
1819 Perl_dump_indent(aTHX_ level+1, file,
1820 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1823 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1824 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1825 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1830 Perl_dump_indent(aTHX_ level+1, file,
1831 "%2d. 0x%" UVxf "<%lu>\n",
1834 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1845 dump the contents of a CV
1851 S_cv_dump(pTHX_ const CV *cv, const char *title)
1853 const CV * const outside = CvOUTSIDE(cv);
1854 PADLIST* const padlist = CvPADLIST(cv);
1856 PERL_ARGS_ASSERT_CV_DUMP;
1858 PerlIO_printf(Perl_debug_log,
1859 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1862 (CvANON(cv) ? "ANON"
1863 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1864 : (cv == PL_main_cv) ? "MAIN"
1865 : CvUNIQUE(cv) ? "UNIQUE"
1866 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1869 : CvANON(outside) ? "ANON"
1870 : (outside == PL_main_cv) ? "MAIN"
1871 : CvUNIQUE(outside) ? "UNIQUE"
1872 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1874 PerlIO_printf(Perl_debug_log,
1875 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1876 do_dump_pad(1, Perl_debug_log, padlist, 1);
1879 #endif /* DEBUGGING */
1882 =for apidoc cv_clone
1884 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1885 of the function: its code, pad structure, and other attributes.
1886 The prototype is combined with a capture of outer lexicals to which the
1887 code refers, which are taken from the currently-executing instance of
1888 the immediately surrounding code.
1893 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1896 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1900 PADLIST* const protopadlist = CvPADLIST(proto);
1901 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1902 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1903 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1904 SV** const ppad = AvARRAY(protopad);
1905 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1906 const PADOFFSET fpad = AvFILLp(protopad);
1910 bool trouble = FALSE;
1912 assert(!CvUNIQUE(proto));
1914 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1915 * reliable. The currently-running sub is always the one we need to
1917 * For my subs, the currently-running sub may not be the one we want.
1918 * We have to check whether it is a clone of CvOUTSIDE.
1919 * Note that in general for formats, CvOUTSIDE != find_runcv.
1920 * Since formats may be nested inside closures, CvOUTSIDE may point
1921 * to a prototype; we instead want the cloned parent who called us.
1925 if (CvWEAKOUTSIDE(proto))
1926 outside = find_runcv(NULL);
1928 outside = CvOUTSIDE(proto);
1929 if ((CvCLONE(outside) && ! CvCLONED(outside))
1930 || !CvPADLIST(outside)
1931 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1932 outside = find_runcv_where(
1933 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1935 /* outside could be null */
1939 depth = outside ? CvDEPTH(outside) : 0;
1944 SAVESPTR(PL_compcv);
1946 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1949 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1951 SAVESPTR(PL_comppad_name);
1952 PL_comppad_name = protopad_name;
1953 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1954 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1956 av_fill(PL_comppad, fpad);
1958 PL_curpad = AvARRAY(PL_comppad);
1960 outpad = outside && CvPADLIST(outside)
1961 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1963 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1965 for (ix = fpad; ix > 0; ix--) {
1966 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1968 if (namesv && PadnameLEN(namesv)) { /* lexical */
1969 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1973 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1974 /* formats may have an inactive, or even undefined, parent;
1975 but state vars are always available. */
1976 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
1977 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
1978 && (!outside || !CvDEPTH(outside))) ) {
1979 S_unavailable(aTHX_ namesv);
1983 SvREFCNT_inc_simple_void_NN(sv);
1986 const char sigil = PadnamePV(namesv)[0];
1988 /* If there are state subs, we need to clone them, too.
1989 But they may need to close over variables we have
1990 not cloned yet. So we will have to do a second
1991 pass. Furthermore, there may be state subs clos-
1992 ing over other state subs’ entries, so we have
1993 to put a stub here and then clone into it on the
1995 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
1996 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
1998 if (CvOUTSIDE(ppad[ix]) != proto)
2000 sv = newSV_type(SVt_PVCV);
2003 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2006 /* Just provide a stub, but name it. It will be
2007 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));
2131 PADNAME * const pn =
2132 PadlistNAMESARRAY(CvPADLIST(outside))
2133 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2134 CvPADLIST(cv))[o->op_targ])];
2135 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2137 if (PadnameLVALUE(pn)) {
2138 /* We have a lexical that is potentially modifiable
2139 elsewhere, so making a constant will break clo-
2140 sure behaviour. If this is a ‘simple lexical
2141 op tree’, i.e., sub(){$x}, emit a deprecation
2142 warning, but continue to exhibit the old behav-
2143 iour of making it a constant based on the ref-
2144 count of the candidate variable.
2146 A simple lexical op tree looks like this:
2154 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2159 "Constants from lexical variables potentially modified "
2160 "elsewhere are no longer permitted");
2166 SvREFCNT_inc_simple_void_NN(const_sv);
2167 /* If the lexical is not used elsewhere, it is safe to turn on
2168 SvPADTMP, since it is only when it is used in lvalue con-
2169 text that the difference is observable. */
2170 SvREADONLY_on(const_sv);
2171 SvPADTMP_on(const_sv);
2172 SvREFCNT_dec_NN(cv);
2173 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2187 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2191 const bool newcv = !cv;
2193 assert(!CvUNIQUE(proto));
2195 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2196 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2200 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2203 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2204 else CvGV_set(cv,CvGV(proto));
2205 CvSTASH_set(cv, CvSTASH(proto));
2207 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2209 CvSTART(cv) = CvSTART(proto);
2210 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2213 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2215 SvUTF8_on(MUTABLE_SV(cv));
2218 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2220 if (CvPADLIST(proto))
2221 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2224 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2225 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2226 cv_dump(proto, "Proto");
2234 Perl_cv_clone(pTHX_ CV *proto)
2236 PERL_ARGS_ASSERT_CV_CLONE;
2238 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2239 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2242 /* Called only by pp_clonecv */
2244 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2246 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2248 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2254 Returns an SV containing the name of the CV, mainly for use in error
2255 reporting. The CV may actually be a GV instead, in which case the returned
2256 SV holds the GV's name. Anything other than a GV or CV is treated as a
2257 string already holding the sub name, but this could change in the future.
2259 An SV may be passed as a second argument. If so, the name will be assigned
2260 to it and it will be returned. Otherwise the returned SV will be a new
2263 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2264 included. If the first argument is neither a CV nor a GV, this flag is
2265 ignored (subject to change).
2267 =for apidoc Amnh||CV_NAME_NOTQUAL
2273 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2275 PERL_ARGS_ASSERT_CV_NAME;
2276 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2277 if (sv) sv_setsv(sv,(SV *)cv);
2278 return sv ? (sv) : (SV *)cv;
2281 SV * const retsv = sv ? (sv) : sv_newmortal();
2282 if (SvTYPE(cv) == SVt_PVCV) {
2284 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2285 sv_sethek(retsv, CvNAME_HEK(cv));
2287 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2288 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2290 sv_setpvs(retsv, "__ANON__");
2291 sv_catpvs(retsv, "::");
2292 sv_cathek(retsv, CvNAME_HEK(cv));
2295 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2296 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2297 else gv_efullname3(retsv, CvGV(cv), NULL);
2299 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2300 else gv_efullname3(retsv,(GV *)cv,NULL);
2306 =for apidoc pad_fixup_inner_anons
2308 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2309 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2310 moved to a pre-existing CV struct.
2316 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2319 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2320 AV * const comppad = PadlistARRAY(padlist)[1];
2321 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2322 SV ** const curpad = AvARRAY(comppad);
2324 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2325 PERL_UNUSED_ARG(old_cv);
2327 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2328 const PADNAME *name = namepad[ix];
2329 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2330 && *PadnamePV(name) == '&')
2332 CV *innercv = MUTABLE_CV(curpad[ix]);
2333 if (UNLIKELY(PadnameOUTER(name))) {
2335 PADNAME **names = namepad;
2337 while (PadnameOUTER(name)) {
2338 assert(SvTYPE(cv) == SVt_PVCV);
2340 names = PadlistNAMESARRAY(CvPADLIST(cv));
2341 i = PARENT_PAD_INDEX(name);
2344 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2346 if (SvTYPE(innercv) == SVt_PVCV) {
2347 /* XXX 0afba48f added code here to check for a proto CV
2348 attached to the pad entry by magic. But shortly there-
2349 after 81df9f6f95 moved the magic to the pad name. The
2350 code here was never updated, so it wasn’t doing anything
2351 and got deleted when PADNAME became a distinct type. Is
2352 there any bug as a result? */
2353 if (CvOUTSIDE(innercv) == old_cv) {
2354 if (!CvWEAKOUTSIDE(innercv)) {
2355 SvREFCNT_dec(old_cv);
2356 SvREFCNT_inc_simple_void_NN(new_cv);
2358 CvOUTSIDE(innercv) = new_cv;
2361 else { /* format reference */
2362 SV * const rv = curpad[ix];
2364 if (!SvOK(rv)) continue;
2366 assert(SvWEAKREF(rv));
2367 innercv = (CV *)SvRV(rv);
2368 assert(!CvWEAKOUTSIDE(innercv));
2369 assert(CvOUTSIDE(innercv) == old_cv);
2370 SvREFCNT_dec(CvOUTSIDE(innercv));
2371 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2378 =for apidoc pad_push
2380 Push a new pad frame onto the padlist, unless there's already a pad at
2381 this depth, in which case don't bother creating a new one. Then give
2382 the new pad an C<@_> in slot zero.
2388 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2390 PERL_ARGS_ASSERT_PAD_PUSH;
2392 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2393 PAD** const svp = PadlistARRAY(padlist);
2394 AV* const newpad = newAV();
2395 SV** const oldpad = AvARRAY(svp[depth-1]);
2396 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2397 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2398 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2401 for ( ;ix > 0; ix--) {
2402 if (names_fill >= ix && PadnameLEN(names[ix])) {
2403 const char sigil = PadnamePV(names[ix])[0];
2404 if (PadnameOUTER(names[ix])
2405 || PadnameIsSTATE(names[ix])
2408 /* outer lexical or anon code */
2409 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2411 else { /* our own lexical */
2414 sv = MUTABLE_SV(newAV());
2415 else if (sigil == '%')
2416 sv = MUTABLE_SV(newHV());
2419 av_store(newpad, ix, sv);
2422 else if (PadnamePV(names[ix])) {
2423 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2426 /* save temporaries on recursion? */
2427 SV * const sv = newSV(0);
2428 av_store(newpad, ix, sv);
2433 av_store(newpad, 0, MUTABLE_SV(av));
2436 padlist_store(padlist, depth, newpad);
2440 #if defined(USE_ITHREADS)
2442 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2445 =for apidoc padlist_dup
2453 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2459 PERL_ARGS_ASSERT_PADLIST_DUP;
2461 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2462 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2464 max = cloneall ? PadlistMAX(srcpad) : 1;
2466 Newx(dstpad, 1, PADLIST);
2467 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2468 PadlistMAX(dstpad) = max;
2469 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2471 PadlistARRAY(dstpad)[0] = (PAD *)
2472 padnamelist_dup(PadlistNAMES(srcpad), param);
2473 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2476 for (depth = 1; depth <= max; ++depth)
2477 PadlistARRAY(dstpad)[depth] =
2478 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2480 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2481 to build anything other than the first level of pads. */
2482 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2484 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2485 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2486 SV **oldpad = AvARRAY(srcpad1);
2487 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2493 av_extend(pad1, ix);
2494 PadlistARRAY(dstpad)[1] = pad1;
2495 pad1a = AvARRAY(pad1);
2500 for ( ;ix > 0; ix--) {
2503 } else if (names_fill >= ix && names[ix] &&
2504 PadnameLEN(names[ix])) {
2505 const char sigil = PadnamePV(names[ix])[0];
2506 if (PadnameOUTER(names[ix])
2507 || PadnameIsSTATE(names[ix])
2510 /* outer lexical or anon code */
2511 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2513 else { /* our own lexical */
2514 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2515 /* This is a work around for how the current
2516 implementation of ?{ } blocks in regexps
2517 interacts with lexicals. */
2518 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2523 sv = MUTABLE_SV(newAV());
2524 else if (sigil == '%')
2525 sv = MUTABLE_SV(newHV());
2532 else if (( names_fill >= ix && names[ix]
2533 && PadnamePV(names[ix]) )) {
2534 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2537 /* save temporaries on recursion? */
2538 SV * const sv = newSV(0);
2541 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2542 FIXTHAT before merging this branch.
2543 (And I know how to) */
2544 if (SvPADTMP(oldpad[ix]))
2550 args = newAV(); /* Will be @_ */
2552 pad1a[0] = (SV *)args;
2560 #endif /* USE_ITHREADS */
2563 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2566 SSize_t const oldmax = PadlistMAX(padlist);
2568 PERL_ARGS_ASSERT_PADLIST_STORE;
2572 if (key > PadlistMAX(padlist)) {
2573 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2574 (SV ***)&PadlistARRAY(padlist),
2575 (SV ***)&PadlistARRAY(padlist));
2576 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2579 ary = PadlistARRAY(padlist);
2580 SvREFCNT_dec(ary[key]);
2586 =for apidoc newPADNAMELIST
2588 Creates a new pad name list. C<max> is the highest index for which space
2595 Perl_newPADNAMELIST(size_t max)
2598 Newx(pnl, 1, PADNAMELIST);
2599 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2600 PadnamelistMAX(pnl) = -1;
2601 PadnamelistREFCNT(pnl) = 1;
2602 PadnamelistMAXNAMED(pnl) = 0;
2603 pnl->xpadnl_max = max;
2608 =for apidoc padnamelist_store
2610 Stores the pad name (which may be null) at the given index, freeing any
2611 existing pad name in that slot.
2617 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2621 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2625 if (key > pnl->xpadnl_max)
2626 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2627 (SV ***)&PadnamelistARRAY(pnl),
2628 (SV ***)&PadnamelistARRAY(pnl));
2629 if (PadnamelistMAX(pnl) < key) {
2630 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2631 key-PadnamelistMAX(pnl), PADNAME *);
2632 PadnamelistMAX(pnl) = key;
2634 ary = PadnamelistARRAY(pnl);
2636 PadnameREFCNT_dec(ary[key]);
2642 =for apidoc padnamelist_fetch
2644 Fetches the pad name from the given index.
2650 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2652 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2655 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2659 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2661 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2662 if (!--PadnamelistREFCNT(pnl)) {
2663 while(PadnamelistMAX(pnl) >= 0)
2665 PADNAME * const pn =
2666 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2668 PadnameREFCNT_dec(pn);
2670 Safefree(PadnamelistARRAY(pnl));
2675 #if defined(USE_ITHREADS)
2678 =for apidoc padnamelist_dup
2680 Duplicates a pad name list.
2686 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2688 PADNAMELIST *dstpad;
2689 SSize_t max = PadnamelistMAX(srcpad);
2691 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2693 /* look for it in the table first */
2694 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2698 dstpad = newPADNAMELIST(max);
2699 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2700 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2701 PadnamelistMAX(dstpad) = max;
2703 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2704 for (; max >= 0; max--)
2705 if (PadnamelistARRAY(srcpad)[max]) {
2706 PadnamelistARRAY(dstpad)[max] =
2707 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2708 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2714 #endif /* USE_ITHREADS */
2717 =for apidoc newPADNAMEpvn
2719 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2720 use this for pad names that point to outer lexicals. See
2721 C<L</newPADNAMEouter>>.
2727 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2729 struct padname_with_str *alloc;
2730 char *alloc2; /* for Newxz */
2732 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2734 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2736 alloc = (struct padname_with_str *)alloc2;
2737 pn = (PADNAME *)alloc;
2738 PadnameREFCNT(pn) = 1;
2739 PadnamePV(pn) = alloc->xpadn_str;
2740 Copy(s, PadnamePV(pn), len, char);
2741 *(PadnamePV(pn) + len) = '\0';
2742 PadnameLEN(pn) = len;
2747 =for apidoc newPADNAMEouter
2749 Constructs and returns a new pad name. Only use this function for names
2750 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2751 the outer pad name that this one mirrors. The returned pad name has the
2752 C<PADNAMEt_OUTER> flag already set.
2754 =for apidoc Amnh||PADNAMEt_OUTER
2760 Perl_newPADNAMEouter(PADNAME *outer)
2763 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2764 Newxz(pn, 1, PADNAME);
2765 PadnameREFCNT(pn) = 1;
2766 PadnamePV(pn) = PadnamePV(outer);
2767 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2768 another entry. The original pad name owns the buffer. */
2769 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2770 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2771 PadnameLEN(pn) = PadnameLEN(outer);
2776 Perl_padname_free(pTHX_ PADNAME *pn)
2778 PERL_ARGS_ASSERT_PADNAME_FREE;
2779 if (!--PadnameREFCNT(pn)) {
2780 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2781 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2784 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2785 SvREFCNT_dec(PadnameOURSTASH(pn));
2786 if (PadnameOUTER(pn))
2787 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2792 #if defined(USE_ITHREADS)
2795 =for apidoc padname_dup
2797 Duplicates a pad name.
2803 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2807 PERL_ARGS_ASSERT_PADNAME_DUP;
2809 /* look for it in the table first */
2810 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2814 if (!PadnamePV(src)) {
2815 dst = &PL_padname_undef;
2816 ptr_table_store(PL_ptr_table, src, dst);
2820 dst = PadnameOUTER(src)
2821 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2822 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2823 ptr_table_store(PL_ptr_table, src, dst);
2824 PadnameLEN(dst) = PadnameLEN(src);
2825 PadnameFLAGS(dst) = PadnameFLAGS(src);
2826 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2827 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2828 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2830 dst->xpadn_low = src->xpadn_low;
2831 dst->xpadn_high = src->xpadn_high;
2832 dst->xpadn_gen = src->xpadn_gen;
2836 #endif /* USE_ITHREADS */
2839 * ex: set ts=8 sts=4 sw=4 et: