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
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 SAVESTRLEN(PL_padix);
208 SAVESTRLEN(PL_constpadix);
209 SAVESTRLEN(PL_comppad_name_fill);
210 SAVESTRLEN(PL_min_intro_pending);
211 SAVESTRLEN(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);
223 Newxz(AvALLOC(pad), 4, SV *); /* Originally sized to
224 match av_extend default */
225 AvARRAY(pad) = AvALLOC(pad);
227 AvFILLp(pad) = 0; /* @_ or NULL, set below. */
229 if (flags & padnew_CLONE) {
230 AV * const a0 = newAV(); /* will be @_ */
231 AvARRAY(pad)[0] = MUTABLE_SV(a0);
234 PadnamelistREFCNT(padname = PL_comppad_name)++;
237 padlist->xpadl_id = PL_padlist_generation++;
238 /* Set implicitly through use of Newxz above
239 AvARRAY(pad)[0] = NULL;
241 padname = newPADNAMELIST(0);
242 padnamelist_store(padname, 0, &PL_padname_undef);
245 /* Most subroutines never recurse, hence only need 2 entries in the padlist
246 array - names, and depth=1. The default for av_store() is to allocate
247 0..3, and even an explicit call to av_extend() with <3 will be rounded
248 up, so we inline the allocation of the array here. */
250 PadlistMAX(padlist) = 1;
251 PadlistARRAY(padlist) = ary;
252 ary[0] = (PAD *)padname;
255 /* ... then update state variables */
258 PL_curpad = AvARRAY(pad);
260 if (! (flags & padnew_CLONE)) {
261 PL_comppad_name = padname;
262 PL_comppad_name_fill = 0;
263 PL_min_intro_pending = 0;
269 DEBUG_X(PerlIO_printf(Perl_debug_log,
270 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
271 " name=0x%" UVxf " flags=0x%" UVxf "\n",
272 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
273 PTR2UV(padname), (UV)flags
277 return (PADLIST*)padlist;
282 =for apidoc_section $embedding
286 Clear out all the active components of a CV. This can happen either
287 by an explicit C<undef &foo>, or by the reference count going to zero.
288 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
289 children can still follow the full lexical scope chain.
295 Perl_cv_undef(pTHX_ CV *cv)
297 PERL_ARGS_ASSERT_CV_UNDEF;
298 cv_undef_flags(cv, 0);
302 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
304 CV cvbody;/*CV body will never be realloced inside this func,
305 so dont read it more than once, use fake CV so existing macros
306 will work, the indirection and CV head struct optimized away*/
307 SvANY(&cvbody) = SvANY(cv);
309 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
312 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
313 PTR2UV(cv), PTR2UV(PL_comppad))
316 if (CvFILE(&cvbody)) {
317 char * file = CvFILE(&cvbody);
318 CvFILE(&cvbody) = NULL;
319 if(CvDYNFILE(&cvbody))
323 /* CvSLABBED_off(&cvbody); *//* turned off below */
324 /* release the sub's body */
325 if (!CvISXSUB(&cvbody)) {
326 if(CvROOT(&cvbody)) {
327 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
328 if (CvDEPTHunsafe(&cvbody)) {
329 assert(SvTYPE(cv) == SVt_PVCV);
330 Perl_croak_nocontext("Can't undef active subroutine");
334 PAD_SAVE_SETNULLPAD();
336 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
337 op_free(CvROOT(&cvbody));
338 CvROOT(&cvbody) = NULL;
339 CvSTART(&cvbody) = NULL;
342 else if (CvSLABBED(&cvbody)) {
343 if( CvSTART(&cvbody)) {
345 PAD_SAVE_SETNULLPAD();
347 /* discard any leaked ops */
349 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
350 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
351 CvSTART(&cvbody) = NULL;
356 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
360 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
361 CvXSUB(&cvbody) = NULL;
363 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
364 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
365 if (!(flags & CV_UNDEF_KEEP_NAME)) {
366 if (CvNAMED(&cvbody)) {
367 CvNAME_HEK_set(&cvbody, NULL);
368 CvNAMED_off(&cvbody);
370 else CvGV_set(cv, NULL);
373 /* This statement and the subsequence if block was pad_undef(). */
374 pad_peg("pad_undef");
376 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
378 const PADLIST *padlist = CvPADLIST(&cvbody);
380 /* Free the padlist associated with a CV.
381 If parts of it happen to be current, we null the relevant PL_*pad*
382 global vars so that we don't have any dangling references left.
383 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
384 subs to the outer of this cv. */
386 DEBUG_X(PerlIO_printf(Perl_debug_log,
387 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
388 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
391 /* detach any '&' anon children in the pad; if afterwards they
392 * are still live, fix up their CvOUTSIDEs to point to our outside,
395 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
396 CV * const outercv = CvOUTSIDE(&cvbody);
397 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
398 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
399 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
400 PAD * const comppad = PadlistARRAY(padlist)[1];
401 SV ** const curpad = AvARRAY(comppad);
402 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
403 PADNAME * const name = namepad[ix];
404 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
406 CV * const innercv = MUTABLE_CV(curpad[ix]);
409 assert(SvTYPE(innercv) != SVt_PVFM);
410 inner_rc = SvREFCNT(innercv);
413 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
415 SvREFCNT_dec_NN(innercv);
419 /* in use, not just a prototype */
420 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
421 && (CvOUTSIDE(innercv) == cv))
423 assert(CvWEAKOUTSIDE(innercv));
424 /* don't relink to grandfather if he's being freed */
425 if (outercv && SvREFCNT(outercv)) {
426 CvWEAKOUTSIDE_off(innercv);
427 CvOUTSIDE(innercv) = outercv;
428 CvOUTSIDE_SEQ(innercv) = seq;
429 SvREFCNT_inc_simple_void_NN(outercv);
432 CvOUTSIDE(innercv) = NULL;
439 ix = PadlistMAX(padlist);
441 PAD * const sv = PadlistARRAY(padlist)[ix--];
443 if (sv == PL_comppad) {
451 PADNAMELIST * const names = PadlistNAMES(padlist);
452 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
453 PL_comppad_name = NULL;
454 PadnamelistREFCNT_dec(names);
456 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
458 CvPADLIST_set(&cvbody, NULL);
460 else if (CvISXSUB(&cvbody))
461 CvHSCXT(&cvbody) = NULL;
462 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
465 /* remove CvOUTSIDE unless this is an undef rather than a free */
467 CV * outside = CvOUTSIDE(&cvbody);
469 CvOUTSIDE(&cvbody) = NULL;
470 if (!CvWEAKOUTSIDE(&cvbody))
471 SvREFCNT_dec_NN(outside);
474 if (CvCONST(&cvbody)) {
475 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
476 /* CvCONST_off(cv); *//* turned off below */
478 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
479 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
480 * LEXICAL, which are used to determine the sub's name. */
481 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
486 =for apidoc cv_forget_slab
488 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
489 for making sure it is freed. (Hence, no two CVs should ever have a
490 reference count on the same slab.) The CV only needs to reference the slab
491 during compilation. Once it is compiled and C<CvROOT> attached, it has
492 finished its job, so it can forget the slab.
498 Perl_cv_forget_slab(pTHX_ CV *cv)
505 slabbed = cBOOL(CvSLABBED(cv));
506 if (!slabbed) return;
510 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
511 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
513 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
517 #ifdef PERL_DEBUG_READONLY_OPS
518 const size_t refcnt = slab->opslab_refcnt;
520 OpslabREFCNT_dec(slab);
521 #ifdef PERL_DEBUG_READONLY_OPS
522 if (refcnt > 1) Slab_to_ro(slab);
528 =for apidoc pad_alloc_name
530 Allocates a place in the currently-compiling
531 pad (via L<perlapi/pad_alloc>) and
532 then stores a name for that entry. C<name> is adopted and
533 becomes the name entry; it must already contain the name
534 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
535 flag get added to C<name>. None of the other
536 processing of L<perlapi/pad_add_name_pvn>
537 is done. Returns the offset of the allocated pad slot.
543 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
546 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
548 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
550 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
553 SvPAD_TYPED_on(name);
555 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
559 SvOURSTASH_set(name, ourstash);
560 SvREFCNT_inc_simple_void_NN(ourstash);
562 else if (flags & padadd_STATE) {
563 SvPAD_STATE_on(name);
566 padnamelist_store(PL_comppad_name, offset, name);
567 if (PadnameLEN(name) > 1)
568 PadnamelistMAXNAMED(PL_comppad_name) = offset;
573 =for apidoc pad_add_name_pvn
575 Allocates a place in the currently-compiling pad for a named lexical
576 variable. Stores the name and other metadata in the name part of the
577 pad, and makes preparations to manage the variable's lexical scoping.
578 Returns the offset of the allocated pad slot.
580 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
581 If C<typestash> is non-null, the name is for a typed lexical, and this
582 identifies the type. If C<ourstash> is non-null, it's a lexical reference
583 to a package variable, and this identifies the package. The following
584 flags can be OR'ed together:
586 padadd_OUR redundantly specifies if it's a package var
587 padadd_STATE variable will retain value persistently
588 padadd_NO_DUP_CHECK skip check for lexical shadowing
594 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
595 U32 flags, HV *typestash, HV *ourstash)
600 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
602 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
603 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
606 name = newPADNAMEpvn(namepv, namelen);
608 if ((flags & padadd_NO_DUP_CHECK) == 0) {
610 SAVEFREEPADNAME(name); /* in case of fatal warnings */
611 /* check for duplicate declaration */
612 pad_check_dup(name, flags & padadd_OUR, ourstash);
613 PadnameREFCNT(name)++;
617 offset = pad_alloc_name(name, flags, typestash, ourstash);
619 /* not yet introduced */
620 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
621 COP_SEQ_RANGE_HIGH_set(name, 0);
623 if (!PL_min_intro_pending)
624 PL_min_intro_pending = offset;
625 PL_max_intro_pending = offset;
626 /* if it's not a simple scalar, replace with an AV or HV */
627 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
628 assert(SvREFCNT(PL_curpad[offset]) == 1);
629 if (namelen != 0 && *namepv == '@')
630 sv_upgrade(PL_curpad[offset], SVt_PVAV);
631 else if (namelen != 0 && *namepv == '%')
632 sv_upgrade(PL_curpad[offset], SVt_PVHV);
633 else if (namelen != 0 && *namepv == '&')
634 sv_upgrade(PL_curpad[offset], SVt_PVCV);
635 assert(SvPADMY(PL_curpad[offset]));
636 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
637 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
638 (long)offset, PadnamePV(name),
639 PTR2UV(PL_curpad[offset])));
645 =for apidoc pad_add_name_pv
647 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
648 instead of a string/length pair.
654 Perl_pad_add_name_pv(pTHX_ const char *name,
655 const U32 flags, HV *typestash, HV *ourstash)
657 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
658 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
662 =for apidoc pad_add_name_sv
664 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
665 of an SV instead of a string/length pair.
671 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
675 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
676 namepv = SvPVutf8(name, namelen);
677 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
681 =for apidoc pad_alloc
683 Allocates a place in the currently-compiling pad,
684 returning the offset of the allocated pad slot.
685 No name is initially attached to the pad slot.
686 C<tmptype> is a set of flags indicating the kind of pad entry required,
687 which will be set in the value SV for the allocated pad entry:
689 SVs_PADMY named lexical variable ("my", "our", "state")
690 SVs_PADTMP unnamed temporary store
691 SVf_READONLY constant shared between recursion levels
693 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
694 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
695 does not cause the SV in the pad slot to be marked read-only, but simply
696 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
697 least should be treated as such.
699 C<optype> should be an opcode indicating the type of operation that the
700 pad entry is to support. This doesn't affect operational semantics,
701 but is used for debugging.
707 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
712 PERL_UNUSED_ARG(optype);
713 ASSERT_CURPAD_ACTIVE("pad_alloc");
715 if (AvARRAY(PL_comppad) != PL_curpad)
716 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
717 AvARRAY(PL_comppad), PL_curpad);
718 if (PL_pad_reset_pending)
720 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
721 /* For a my, simply push a null SV onto the end of PL_comppad. */
722 sv = *av_store_simple(PL_comppad, AvFILLp(PL_comppad) + 1, newSV(0));
723 retval = (PADOFFSET)AvFILLp(PL_comppad);
726 /* For a tmp, scan the pad from PL_padix upwards
727 * for a slot which has no name and no active value.
728 * For a constant, likewise, but use PL_constpadix.
730 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
731 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
732 const bool konst = cBOOL(tmptype & SVf_READONLY);
733 retval = konst ? PL_constpadix : PL_padix;
736 * Entries that close over unavailable variables
737 * in outer subs contain values not marked PADMY.
738 * Thus we must skip, not just pad values that are
739 * marked as current pad values, but also those with names.
740 * If pad_reset is enabled, ‘current’ means different
741 * things depending on whether we are allocating a con-
742 * stant or a target. For a target, things marked PADTMP
743 * can be reused; not so for constants.
746 if (++retval <= names_fill &&
747 (pn = names[retval]) && PadnamePV(pn))
749 sv = *av_fetch_simple(PL_comppad, retval, TRUE);
752 (konst ? SVs_PADTMP : 0)
760 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
761 tmptype &= ~SVf_READONLY;
762 tmptype |= SVs_PADTMP;
764 *(konst ? &PL_constpadix : &PL_padix) = retval;
766 SvFLAGS(sv) |= tmptype;
767 PL_curpad = AvARRAY(PL_comppad);
769 DEBUG_X(PerlIO_printf(Perl_debug_log,
770 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
771 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
772 PL_op_name[optype]));
773 #ifdef DEBUG_LEAKING_SCALARS
774 sv->sv_debug_optype = optype;
775 sv->sv_debug_inpad = 1;
781 =for apidoc pad_add_anon
783 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
784 for an anonymous function that is lexically scoped inside the
785 currently-compiling function.
786 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
787 to the outer scope is weakened to avoid a reference loop.
789 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
791 C<optype> should be an opcode indicating the type of operation that the
792 pad entry is to support. This doesn't affect operational semantics,
793 but is used for debugging.
799 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
802 PADNAME * const name = newPADNAMEpvn("&", 1);
804 PERL_ARGS_ASSERT_PAD_ADD_ANON;
805 assert (SvTYPE(func) == SVt_PVCV);
808 /* These two aren't used; just make sure they're not equal to
809 * PERL_PADSEQ_INTRO. They should be 0 by default. */
810 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
811 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
812 ix = pad_alloc(optype, SVs_PADMY);
813 padnamelist_store(PL_comppad_name, ix, name);
814 av_store(PL_comppad, ix, (SV*)func);
816 /* to avoid ref loops, we never have parent + child referencing each
817 * other simultaneously */
818 if (CvOUTSIDE(func)) {
819 assert(!CvWEAKOUTSIDE(func));
820 CvWEAKOUTSIDE_on(func);
821 SvREFCNT_dec_NN(CvOUTSIDE(func));
827 Perl_pad_add_weakref(pTHX_ CV* func)
829 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
830 PADNAME * const name = newPADNAMEpvn("&", 1);
831 SV * const rv = newRV_inc((SV *)func);
833 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
835 /* These two aren't used; just make sure they're not equal to
836 * PERL_PADSEQ_INTRO. They should be 0 by default. */
837 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
838 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
839 padnamelist_store(PL_comppad_name, ix, name);
841 av_store(PL_comppad, ix, rv);
845 =for apidoc pad_check_dup
847 Check for duplicate declarations: report any of:
849 * a 'my' in the current scope with the same name;
850 * an 'our' (anywhere in the pad) with the same name and the
851 same stash as 'ourstash'
853 C<is_our> indicates that the name to check is an C<"our"> declaration.
859 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
863 const U32 is_our = flags & padadd_OUR;
865 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
867 ASSERT_CURPAD_ACTIVE("pad_check_dup");
869 assert((flags & ~padadd_OUR) == 0);
871 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
872 return; /* nothing to check */
874 svp = PadnamelistARRAY(PL_comppad_name);
875 top = PadnamelistMAX(PL_comppad_name);
876 /* check the current scope */
877 for (off = top; off > PL_comppad_name_floor; off--) {
878 PADNAME * const sv = svp[off];
880 && PadnameLEN(sv) == PadnameLEN(name)
882 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
883 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
884 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
886 if (is_our && (SvPAD_OUR(sv)))
887 break; /* "our" masking "our" */
888 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
889 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
890 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
892 PL_parser->in_my == KEY_my ? "my" :
893 PL_parser->in_my == KEY_sigvar ? "my" :
895 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
897 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
898 ? "scope" : "statement"));
903 /* check the rest of the pad */
906 PADNAME * const sv = svp[off];
908 && PadnameLEN(sv) == PadnameLEN(name)
910 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
911 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
912 && SvOURSTASH(sv) == ourstash
913 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
915 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
916 "\"our\" variable %" PNf " redeclared", PNfARG(sv));
917 if (off <= PL_comppad_name_floor)
918 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
919 "\t(Did you mean \"local\" instead of \"our\"?)\n");
929 =for apidoc pad_findmy_pvn
931 Given the name of a lexical variable, find its position in the
932 currently-compiling pad.
933 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
934 C<flags> is reserved and must be zero.
935 If it is not in the current pad but appears in the pad of any lexically
936 enclosing scope, then a pseudo-entry for it is added in the current pad.
937 Returns the offset in the current pad,
938 or C<NOT_IN_PAD> if no such lexical is in scope.
944 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
949 const PADNAMELIST *namelist;
952 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
954 pad_peg("pad_findmy_pvn");
957 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
960 /* compilation errors can zero PL_compcv */
964 offset = pad_findlex(namepv, namelen, flags,
965 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
966 if (offset != NOT_IN_PAD)
969 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
971 if (*namepv == '&') return NOT_IN_PAD;
973 /* look for an our that's being introduced; this allows
974 * our $foo = 0 unless defined $foo;
975 * to not give a warning. (Yes, this is a hack) */
977 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
978 name_p = PadnamelistARRAY(namelist);
979 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
980 const PADNAME * const name = name_p[offset];
981 if (name && PadnameLEN(name) == namelen
982 && !PadnameOUTER(name)
983 && (PadnameIsOUR(name))
984 && ( PadnamePV(name) == namepv
985 || memEQ(PadnamePV(name), namepv, namelen) )
986 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
994 =for apidoc pad_findmy_pv
996 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
997 instead of a string/length pair.
1003 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1005 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1006 return pad_findmy_pvn(name, strlen(name), flags);
1010 =for apidoc pad_findmy_sv
1012 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1013 of an SV instead of a string/length pair.
1019 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1023 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1024 namepv = SvPVutf8(name, namelen);
1025 return pad_findmy_pvn(namepv, namelen, flags);
1029 =for apidoc find_rundefsvoffset
1031 Until the lexical C<$_> feature was removed, this function would
1032 find the position of the lexical C<$_> in the pad of the
1033 currently-executing function and return the offset in the current pad,
1036 Now it always returns C<NOT_IN_PAD>.
1042 Perl_find_rundefsvoffset(pTHX)
1044 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1049 =for apidoc find_rundefsv
1051 Returns the global variable C<$_>.
1057 Perl_find_rundefsv(pTHX)
1063 =for apidoc pad_findlex
1065 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1066 in the inner pads if it's found in an outer one.
1068 Returns the offset in the bottom pad of the lex or the fake lex.
1069 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1070 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1071 vars return values, and so are pointers to where the returned values
1072 should be stored. C<out_capture>, if non-null, requests that the innermost
1073 instance of the lexical is captured; C<out_name> is set to the innermost
1074 matched pad name or fake pad name; C<out_flags> returns the flags normally
1075 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1077 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1078 then comes back down, adding fake entries
1079 as it goes. It has to be this way
1080 because fake names in anon prototypes have to store in C<xpadn_low> the
1081 index into the parent pad.
1086 /* the CV has finished being compiled. This is not a sufficient test for
1087 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1088 #define CvCOMPILED(cv) CvROOT(cv)
1090 /* the CV does late binding of its lexicals */
1091 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1094 S_unavailable(pTHX_ PADNAME *name)
1096 /* diag_listed_as: Variable "%s" is not available */
1097 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1098 "%s \"%" PNf "\" is not available",
1099 *PadnamePV(name) == '&'
1106 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1107 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1109 PADOFFSET offset, new_offset;
1112 const PADLIST * const padlist = CvPADLIST(cv);
1113 const bool staleok = !!(flags & padadd_STALEOK);
1115 PERL_ARGS_ASSERT_PAD_FINDLEX;
1117 flags &= ~ padadd_STALEOK; /* one-shot flag */
1119 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1124 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1125 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1126 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1127 out_capture ? " capturing" : "" ));
1129 /* first, search this pad */
1131 if (padlist) { /* not an undef CV */
1132 PADOFFSET fake_offset = 0;
1133 const PADNAMELIST * const names = PadlistNAMES(padlist);
1134 PADNAME * const * const name_p = PadnamelistARRAY(names);
1136 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1137 const PADNAME * const name = name_p[offset];
1138 if (name && PadnameLEN(name) == namelen
1139 && ( PadnamePV(name) == namepv
1140 || memEQ(PadnamePV(name), namepv, namelen) ))
1142 if (PadnameOUTER(name)) {
1143 fake_offset = offset; /* in case we don't find a real one */
1146 if (PadnameIN_SCOPE(name, seq))
1151 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1152 if (offset > 0) { /* not fake */
1154 *out_name = name_p[offset]; /* return the name */
1156 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1157 * instances. For now, we just test !CvUNIQUE(cv), but
1158 * ideally, we should detect my's declared within loops
1159 * etc - this would allow a wider range of 'not stayed
1160 * shared' warnings. We also treated already-compiled
1161 * lexes as not multi as viewed from evals. */
1163 *out_flags = CvANON(cv) ?
1165 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1166 ? PAD_FAKELEX_MULTI : 0;
1168 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1169 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1170 PTR2UV(cv), (long)offset,
1171 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1172 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1174 else { /* fake match */
1175 offset = fake_offset;
1176 *out_name = name_p[offset]; /* return the name */
1177 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1178 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1179 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1180 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1181 (unsigned long) PARENT_PAD_INDEX(*out_name)
1185 /* return the lex? */
1190 if (PadnameIsOUR(*out_name)) {
1191 *out_capture = NULL;
1195 /* trying to capture from an anon prototype? */
1197 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1198 : *out_flags & PAD_FAKELEX_ANON)
1204 *out_capture = NULL;
1210 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1211 && !PadnameIsSTATE(name_p[offset])
1212 && warn && ckWARN(WARN_CLOSURE)) {
1214 /* diag_listed_as: Variable "%s" will not stay
1216 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1217 "%s \"%" UTF8f "\" will not stay shared",
1218 *namepv == '&' ? "Subroutine" : "Variable",
1219 UTF8fARG(1, namelen, namepv));
1222 if (fake_offset && CvANON(cv)
1223 && CvCLONE(cv) &&!CvCLONED(cv))
1226 /* not yet caught - look further up */
1227 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1228 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1231 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1233 newwarn, out_capture, out_name, out_flags);
1238 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1239 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1240 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1241 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1242 PTR2UV(cv), PTR2UV(*out_capture)));
1244 if (SvPADSTALE(*out_capture)
1245 && (!CvDEPTH(cv) || !staleok)
1246 && !PadnameIsSTATE(name_p[offset]))
1250 *out_capture = NULL;
1253 if (!*out_capture) {
1254 if (namelen != 0 && *namepv == '@')
1255 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1256 else if (namelen != 0 && *namepv == '%')
1257 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1258 else if (namelen != 0 && *namepv == '&')
1259 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1261 *out_capture = sv_newmortal();
1269 /* it's not in this pad - try above */
1274 /* out_capture non-null means caller wants us to capture lex; in
1275 * addition we capture ourselves unless it's an ANON/format */
1276 new_capturep = out_capture ? out_capture :
1277 CvLATE(cv) ? NULL : &new_capture;
1279 offset = pad_findlex(namepv, namelen,
1280 flags | padadd_STALEOK*(new_capturep == &new_capture),
1281 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1282 new_capturep, out_name, out_flags);
1283 if (offset == NOT_IN_PAD)
1286 /* found in an outer CV. Add appropriate fake entry to this pad */
1288 /* don't add new fake entries (via eval) to CVs that we have already
1289 * finished compiling, or to undef CVs */
1290 if (CvCOMPILED(cv) || !padlist)
1291 return 0; /* this dummy (and invalid) value isnt used by the caller */
1294 PADNAME *new_name = newPADNAMEouter(*out_name);
1295 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1296 PAD * const ocomppad = PL_comppad;
1297 PL_comppad_name = PadlistNAMES(padlist);
1298 PL_comppad = PadlistARRAY(padlist)[1];
1299 PL_curpad = AvARRAY(PL_comppad);
1302 = pad_alloc_name(new_name,
1303 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1304 PadnameTYPE(*out_name),
1305 PadnameOURSTASH(*out_name)
1308 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1309 "Pad addname: %ld \"%.*s\" FAKE\n",
1311 (int) PadnameLEN(new_name),
1312 PadnamePV(new_name)));
1313 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1315 PARENT_PAD_INDEX_set(new_name, 0);
1316 if (PadnameIsOUR(new_name)) {
1317 NOOP; /* do nothing */
1319 else if (CvLATE(cv)) {
1320 /* delayed creation - just note the offset within parent pad */
1321 PARENT_PAD_INDEX_set(new_name, offset);
1325 /* immediate creation - capture outer value right now */
1326 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1327 /* But also note the offset, as newMYSUB needs it */
1328 PARENT_PAD_INDEX_set(new_name, offset);
1329 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1330 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1331 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1333 *out_name = new_name;
1334 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1336 PL_comppad_name = ocomppad_name;
1337 PL_comppad = ocomppad;
1338 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1348 Get the value at offset C<po> in the current (compiling or executing) pad.
1349 Use macro C<PAD_SV> instead of calling this function directly.
1355 Perl_pad_sv(pTHX_ PADOFFSET po)
1357 ASSERT_CURPAD_ACTIVE("pad_sv");
1360 Perl_croak(aTHX_ "panic: pad_sv po");
1361 DEBUG_X(PerlIO_printf(Perl_debug_log,
1362 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1363 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1365 return PL_curpad[po];
1369 =for apidoc pad_setsv
1371 Set the value at offset C<po> in the current (compiling or executing) pad.
1372 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1378 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1380 PERL_ARGS_ASSERT_PAD_SETSV;
1382 ASSERT_CURPAD_ACTIVE("pad_setsv");
1384 DEBUG_X(PerlIO_printf(Perl_debug_log,
1385 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1386 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1391 #endif /* DEBUGGING */
1394 =for apidoc pad_block_start
1396 Update the pad compilation state variables on entry to a new block.
1402 Perl_pad_block_start(pTHX_ int full)
1404 ASSERT_CURPAD_ACTIVE("pad_block_start");
1405 SAVESTRLEN(PL_comppad_name_floor);
1406 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1408 PL_comppad_name_fill = PL_comppad_name_floor;
1409 if (PL_comppad_name_floor < 0)
1410 PL_comppad_name_floor = 0;
1411 SAVESTRLEN(PL_min_intro_pending);
1412 SAVESTRLEN(PL_max_intro_pending);
1413 PL_min_intro_pending = 0;
1414 SAVESTRLEN(PL_comppad_name_fill);
1415 SAVESTRLEN(PL_padix_floor);
1416 /* PL_padix_floor is what PL_padix is reset to at the start of each
1417 statement, by pad_reset(). We set it when entering a new scope
1418 to keep things like this working:
1419 print "$foo$bar", do { this(); that() . "foo" };
1420 We must not let "$foo$bar" and the later concatenation share the
1422 PL_padix_floor = PL_padix;
1423 PL_pad_reset_pending = FALSE;
1427 =for apidoc intro_my
1429 "Introduce" C<my> variables to visible status. This is called during parsing
1430 at the end of each statement to make lexical variables visible to subsequent
1443 ASSERT_CURPAD_ACTIVE("intro_my");
1444 if (PL_compiling.cop_seq) {
1445 seq = PL_compiling.cop_seq;
1446 PL_compiling.cop_seq = 0;
1449 seq = PL_cop_seqmax;
1450 if (! PL_min_intro_pending)
1453 svp = PadnamelistARRAY(PL_comppad_name);
1454 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1455 PADNAME * const sv = svp[i];
1457 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1458 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1460 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1461 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1462 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1463 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1464 (long)i, PadnamePV(sv),
1465 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1466 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1471 PL_min_intro_pending = 0;
1472 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1473 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1474 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1480 =for apidoc pad_leavemy
1482 Cleanup at end of scope during compilation: set the max seq number for
1483 lexicals in this scope and warn of any lexicals that never got introduced.
1489 Perl_pad_leavemy(pTHX)
1493 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1495 PL_pad_reset_pending = FALSE;
1497 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1498 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1499 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1500 const PADNAME * const name = svp[off];
1501 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1502 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1503 "%" PNf " never introduced",
1507 /* "Deintroduce" my variables that are leaving with this scope. */
1508 for (off = PadnamelistMAX(PL_comppad_name);
1509 off > PL_comppad_name_fill; off--) {
1510 PADNAME * const sv = svp[off];
1511 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1512 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1514 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1515 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1516 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1517 (long)off, PadnamePV(sv),
1518 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1519 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1521 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1522 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1523 OP *kid = newOP(OP_INTROCV, 0);
1525 o = op_prepend_elem(OP_LINESEQ, kid, o);
1530 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1531 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1536 =for apidoc pad_swipe
1538 Abandon the tmp in the current pad at offset C<po> and replace with a
1545 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1547 ASSERT_CURPAD_LEGAL("pad_swipe");
1550 if (AvARRAY(PL_comppad) != PL_curpad)
1551 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1552 AvARRAY(PL_comppad), PL_curpad);
1553 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1554 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1555 (long)po, (long)AvFILLp(PL_comppad));
1557 DEBUG_X(PerlIO_printf(Perl_debug_log,
1558 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1559 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1562 SvREFCNT_dec(PL_curpad[po]);
1565 /* if pad tmps aren't shared between ops, then there's no need to
1566 * create a new tmp when an existing op is freed */
1567 #ifdef USE_PAD_RESET
1568 PL_curpad[po] = newSV(0);
1569 SvPADTMP_on(PL_curpad[po]);
1571 PL_curpad[po] = NULL;
1573 if (PadnamelistMAX(PL_comppad_name) != -1
1574 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1575 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1576 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1578 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1580 /* Use PL_constpadix here, not PL_padix. The latter may have been
1581 reset by pad_reset. We don’t want pad_alloc to have to scan the
1582 whole pad when allocating a constant. */
1583 if (po < PL_constpadix)
1584 PL_constpadix = po - 1;
1588 =for apidoc pad_reset
1590 Mark all the current temporaries for reuse
1595 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1596 * between OPs from different statements. During compilation, at the start
1597 * of each statement pad_reset resets PL_padix back to its previous value.
1598 * When allocating a target, pad_alloc begins its scan through the pad at
1603 #ifdef USE_PAD_RESET
1604 if (AvARRAY(PL_comppad) != PL_curpad)
1605 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1606 AvARRAY(PL_comppad), PL_curpad);
1608 DEBUG_X(PerlIO_printf(Perl_debug_log,
1609 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1610 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1611 (long)PL_padix, (long)PL_padix_floor
1615 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1616 PL_padix = PL_padix_floor;
1619 PL_pad_reset_pending = FALSE;
1623 =for apidoc pad_tidy
1625 Tidy up a pad at the end of compilation of the code to which it belongs.
1626 Jobs performed here are: remove most stuff from the pads of anonsub
1627 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1628 the kind of subroutine:
1630 padtidy_SUB ordinary subroutine
1631 padtidy_SUBCLONE prototype for lexical closure
1632 padtidy_FORMAT format
1638 Perl_pad_tidy(pTHX_ padtidy_type type)
1641 ASSERT_CURPAD_ACTIVE("pad_tidy");
1643 /* If this CV has had any 'eval-capable' ops planted in it:
1644 * i.e. it contains any of:
1648 * * use re 'eval'; /$var/
1651 * Then any anon prototypes in the chain of CVs should be marked as
1652 * cloneable, so that for example the eval's CV in
1656 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1657 * potentially have an eval executed within it.
1660 if (PL_cv_has_eval || PL_perldb) {
1662 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1663 if (cv != PL_compcv && CvCOMPILED(cv))
1664 break; /* no need to mark already-compiled code */
1666 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1667 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1674 /* extend namepad to match curpad */
1675 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1676 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1678 if (type == padtidy_SUBCLONE) {
1679 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1682 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1684 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1687 * The only things that a clonable function needs in its
1688 * pad are anonymous subs, constants and GVs.
1689 * The rest are created anew during cloning.
1691 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1694 if (!(PadnamePV(namesv) &&
1695 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1697 SvREFCNT_dec(PL_curpad[ix]);
1698 PL_curpad[ix] = NULL;
1702 else if (type == padtidy_SUB) {
1703 AV * const av = newAV(); /* Will be @_ */
1704 av_store(PL_comppad, 0, MUTABLE_SV(av));
1708 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1709 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1711 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1712 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1713 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1715 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1716 /* This is a work around for how the current implementation of
1717 ?{ } blocks in regexps interacts with lexicals.
1719 One of our lexicals.
1720 Can't do this on all lexicals, otherwise sub baz() won't
1729 because completion of compiling &bar calling pad_tidy()
1730 would cause (top level) $foo to be marked as stale, and
1731 "no longer available". */
1732 SvPADSTALE_on(PL_curpad[ix]);
1736 PL_curpad = AvARRAY(PL_comppad);
1740 =for apidoc pad_free
1742 Free the SV at offset po in the current pad.
1748 Perl_pad_free(pTHX_ PADOFFSET po)
1750 #ifndef USE_PAD_RESET
1753 ASSERT_CURPAD_LEGAL("pad_free");
1756 if (AvARRAY(PL_comppad) != PL_curpad)
1757 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1758 AvARRAY(PL_comppad), PL_curpad);
1760 Perl_croak(aTHX_ "panic: pad_free po");
1762 DEBUG_X(PerlIO_printf(Perl_debug_log,
1763 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1764 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1767 #ifndef USE_PAD_RESET
1769 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1770 SvFLAGS(sv) &= ~SVs_PADTMP;
1778 =for apidoc do_dump_pad
1780 Dump the contents of a padlist
1786 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1788 const PADNAMELIST *pad_name;
1794 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1799 pad_name = PadlistNAMES(padlist);
1800 pad = PadlistARRAY(padlist)[1];
1801 pname = PadnamelistARRAY(pad_name);
1802 ppad = AvARRAY(pad);
1803 Perl_dump_indent(aTHX_ level, file,
1804 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1805 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1808 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1809 const PADNAME *namesv = pname[ix];
1810 if (namesv && !PadnameLEN(namesv)) {
1814 if (PadnameOUTER(namesv))
1815 Perl_dump_indent(aTHX_ level+1, file,
1816 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1819 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1821 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1822 (unsigned long)PARENT_PAD_INDEX(namesv)
1826 Perl_dump_indent(aTHX_ level+1, file,
1827 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1830 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1831 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1832 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1837 Perl_dump_indent(aTHX_ level+1, file,
1838 "%2d. 0x%" UVxf "<%lu>\n",
1841 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1852 dump the contents of a CV
1858 S_cv_dump(pTHX_ const CV *cv, const char *title)
1860 const CV * const outside = CvOUTSIDE(cv);
1861 PADLIST* const padlist = CvPADLIST(cv);
1863 PERL_ARGS_ASSERT_CV_DUMP;
1865 PerlIO_printf(Perl_debug_log,
1866 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1869 (CvANON(cv) ? "ANON"
1870 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1871 : (cv == PL_main_cv) ? "MAIN"
1872 : CvUNIQUE(cv) ? "UNIQUE"
1873 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1876 : CvANON(outside) ? "ANON"
1877 : (outside == PL_main_cv) ? "MAIN"
1878 : CvUNIQUE(outside) ? "UNIQUE"
1879 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1881 PerlIO_printf(Perl_debug_log,
1882 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1883 do_dump_pad(1, Perl_debug_log, padlist, 1);
1886 #endif /* DEBUGGING */
1889 =for apidoc cv_clone
1891 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1892 of the function: its code, pad structure, and other attributes.
1893 The prototype is combined with a capture of outer lexicals to which the
1894 code refers, which are taken from the currently-executing instance of
1895 the immediately surrounding code.
1900 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1903 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1907 PADLIST* const protopadlist = CvPADLIST(proto);
1908 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1909 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1910 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1911 SV** const ppad = AvARRAY(protopad);
1912 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1913 const PADOFFSET fpad = AvFILLp(protopad);
1917 bool trouble = FALSE;
1919 assert(!CvUNIQUE(proto));
1921 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1922 * reliable. The currently-running sub is always the one we need to
1924 * For my subs, the currently-running sub may not be the one we want.
1925 * We have to check whether it is a clone of CvOUTSIDE.
1926 * Note that in general for formats, CvOUTSIDE != find_runcv.
1927 * Since formats may be nested inside closures, CvOUTSIDE may point
1928 * to a prototype; we instead want the cloned parent who called us.
1932 if (CvWEAKOUTSIDE(proto))
1933 outside = find_runcv(NULL);
1935 outside = CvOUTSIDE(proto);
1936 if ((CvCLONE(outside) && ! CvCLONED(outside))
1937 || !CvPADLIST(outside)
1938 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1939 outside = find_runcv_where(
1940 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1942 /* outside could be null */
1946 depth = outside ? CvDEPTH(outside) : 0;
1951 SAVESPTR(PL_compcv);
1953 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1956 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1958 SAVESPTR(PL_comppad_name);
1959 PL_comppad_name = protopad_name;
1960 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1961 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1963 av_fill(PL_comppad, fpad);
1965 PL_curpad = AvARRAY(PL_comppad);
1967 outpad = outside && CvPADLIST(outside)
1968 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1970 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1972 for (ix = fpad; ix > 0; ix--) {
1973 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1975 if (namesv && PadnameLEN(namesv)) { /* lexical */
1976 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1980 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1981 /* formats may have an inactive, or even undefined, parent;
1982 but state vars are always available. */
1983 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
1984 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
1985 && (!outside || !CvDEPTH(outside))) ) {
1986 S_unavailable(aTHX_ namesv);
1990 SvREFCNT_inc_simple_void_NN(sv);
1993 const char sigil = PadnamePV(namesv)[0];
1995 /* If there are state subs, we need to clone them, too.
1996 But they may need to close over variables we have
1997 not cloned yet. So we will have to do a second
1998 pass. Furthermore, there may be state subs clos-
1999 ing over other state subs’ entries, so we have
2000 to put a stub here and then clone into it on the
2002 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2003 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2005 if (CvOUTSIDE(ppad[ix]) != proto)
2007 sv = newSV_type(SVt_PVCV);
2010 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2013 /* Just provide a stub, but name it. It will be
2014 upgraded to the real thing on scope entry. */
2016 PERL_HASH(hash, PadnamePV(namesv)+1,
2017 PadnameLEN(namesv) - 1);
2018 sv = newSV_type(SVt_PVCV);
2021 share_hek(PadnamePV(namesv)+1,
2022 1 - PadnameLEN(namesv),
2027 else sv = SvREFCNT_inc(ppad[ix]);
2028 else if (sigil == '@')
2029 sv = MUTABLE_SV(newAV());
2030 else if (sigil == '%')
2031 sv = MUTABLE_SV(newHV());
2034 /* reset the 'assign only once' flag on each state var */
2035 if (sigil != '&' && SvPAD_STATE(namesv))
2040 else if (namesv && PadnamePV(namesv)) {
2041 sv = SvREFCNT_inc_NN(ppad[ix]);
2052 if (trouble || cloned) {
2053 /* Uh-oh, we have trouble! At least one of the state subs here
2054 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2055 could be pointing to another state protosub that we are
2056 about to clone. So we have to track which sub clones come
2057 from which protosubs. If the CvOUTSIDE pointer for a parti-
2058 cular sub points to something we have not cloned yet, we
2059 delay cloning it. We must loop through the pad entries,
2060 until we get a full pass with no cloning. If any uncloned
2061 subs remain (probably nested inside anonymous or ‘my’ subs),
2062 then they get cloned in a final pass.
2064 bool cloned_in_this_pass;
2066 cloned = (HV *)sv_2mortal((SV *)newHV());
2068 cloned_in_this_pass = FALSE;
2069 for (ix = fpad; ix > 0; ix--) {
2070 PADNAME * const name =
2071 (ix <= fname) ? pname[ix] : NULL;
2072 if (name && name != &PL_padname_undef
2073 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2074 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2076 CV * const protokey = CvOUTSIDE(ppad[ix]);
2077 CV ** const cvp = protokey == proto
2079 : (CV **)hv_fetch(cloned, (char *)&protokey,
2082 S_cv_clone(aTHX_ (CV *)ppad[ix],
2083 (CV *)PL_curpad[ix],
2085 (void)hv_store(cloned, (char *)&ppad[ix],
2087 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2090 cloned_in_this_pass = TRUE;
2094 } while (cloned_in_this_pass);
2096 for (ix = fpad; ix > 0; ix--) {
2097 PADNAME * const name =
2098 (ix <= fname) ? pname[ix] : NULL;
2099 if (name && name != &PL_padname_undef
2100 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2101 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2102 S_cv_clone(aTHX_ (CV *)ppad[ix],
2103 (CV *)PL_curpad[ix],
2104 CvOUTSIDE(ppad[ix]), cloned);
2107 else for (ix = fpad; ix > 0; ix--) {
2108 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2109 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2110 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2111 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2116 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2120 /* Constant sub () { $x } closing over $x:
2121 * The prototype was marked as a candiate for const-ization,
2122 * so try to grab the current const value, and if successful,
2123 * turn into a const sub:
2126 OP *o = CvSTART(cv);
2128 for (; o; o = o->op_next)
2129 if (o->op_type == OP_PADSV)
2131 ASSUME(o->op_type == OP_PADSV);
2132 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2133 /* the candidate should have 1 ref from this pad and 1 ref
2134 * from the parent */
2135 if (const_sv && SvREFCNT(const_sv) == 2) {
2136 const bool was_method = cBOOL(CvMETHOD(cv));
2138 PADNAME * const pn =
2139 PadlistNAMESARRAY(CvPADLIST(outside))
2140 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2141 CvPADLIST(cv))[o->op_targ])];
2142 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2144 if (PadnameLVALUE(pn)) {
2145 /* We have a lexical that is potentially modifiable
2146 elsewhere, so making a constant will break clo-
2147 sure behaviour. If this is a ‘simple lexical
2148 op tree’, i.e., sub(){$x}, emit a deprecation
2149 warning, but continue to exhibit the old behav-
2150 iour of making it a constant based on the ref-
2151 count of the candidate variable.
2153 A simple lexical op tree looks like this:
2161 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2166 "Constants from lexical variables potentially modified "
2167 "elsewhere are no longer permitted");
2173 SvREFCNT_inc_simple_void_NN(const_sv);
2174 /* If the lexical is not used elsewhere, it is safe to turn on
2175 SvPADTMP, since it is only when it is used in lvalue con-
2176 text that the difference is observable. */
2177 SvREADONLY_on(const_sv);
2178 SvPADTMP_on(const_sv);
2179 SvREFCNT_dec_NN(cv);
2180 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2194 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2196 const bool newcv = !cv;
2198 assert(!CvUNIQUE(proto));
2200 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2201 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2205 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2208 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2209 else CvGV_set(cv,CvGV(proto));
2210 CvSTASH_set(cv, CvSTASH(proto));
2212 /* It is unlikely that proto is an xsub, but it could happen; e.g. if a
2213 * module has performed a lexical sub import trick on an xsub. This
2214 * happens with builtin::import, for example
2216 if (UNLIKELY(CvISXSUB(proto))) {
2217 CvXSUB(cv) = CvXSUB(proto);
2218 CvXSUBANY(cv) = CvXSUBANY(proto);
2222 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2224 CvSTART(cv) = CvSTART(proto);
2225 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2229 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2231 SvUTF8_on(MUTABLE_SV(cv));
2234 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2236 if (!CvISXSUB(proto) && CvPADLIST(proto))
2237 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2240 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2241 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2242 cv_dump(proto, "Proto");
2250 Perl_cv_clone(pTHX_ CV *proto)
2252 PERL_ARGS_ASSERT_CV_CLONE;
2254 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2255 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2258 /* Called only by pp_clonecv */
2260 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2262 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2264 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2270 Returns an SV containing the name of the CV, mainly for use in error
2271 reporting. The CV may actually be a GV instead, in which case the returned
2272 SV holds the GV's name. Anything other than a GV or CV is treated as a
2273 string already holding the sub name, but this could change in the future.
2275 An SV may be passed as a second argument. If so, the name will be assigned
2276 to it and it will be returned. Otherwise the returned SV will be a new
2279 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2280 included. If the first argument is neither a CV nor a GV, this flag is
2281 ignored (subject to change).
2283 =for apidoc Amnh||CV_NAME_NOTQUAL
2289 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2291 PERL_ARGS_ASSERT_CV_NAME;
2292 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2293 if (sv) sv_setsv(sv,(SV *)cv);
2294 return sv ? (sv) : (SV *)cv;
2297 SV * const retsv = sv ? (sv) : sv_newmortal();
2298 if (SvTYPE(cv) == SVt_PVCV) {
2300 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2301 sv_sethek(retsv, CvNAME_HEK(cv));
2303 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2304 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2306 sv_setpvs(retsv, "__ANON__");
2307 sv_catpvs(retsv, "::");
2308 sv_cathek(retsv, CvNAME_HEK(cv));
2311 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2312 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2313 else gv_efullname3(retsv, CvGV(cv), NULL);
2315 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2316 else gv_efullname3(retsv,(GV *)cv,NULL);
2322 =for apidoc pad_fixup_inner_anons
2324 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2325 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2326 moved to a pre-existing CV struct.
2332 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2335 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2336 AV * const comppad = PadlistARRAY(padlist)[1];
2337 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2338 SV ** const curpad = AvARRAY(comppad);
2340 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2341 PERL_UNUSED_ARG(old_cv);
2343 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2344 const PADNAME *name = namepad[ix];
2345 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2346 && *PadnamePV(name) == '&')
2348 CV *innercv = MUTABLE_CV(curpad[ix]);
2349 if (UNLIKELY(PadnameOUTER(name))) {
2351 PADNAME **names = namepad;
2353 while (PadnameOUTER(name)) {
2354 assert(SvTYPE(cv) == SVt_PVCV);
2356 names = PadlistNAMESARRAY(CvPADLIST(cv));
2357 i = PARENT_PAD_INDEX(name);
2360 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2362 if (SvTYPE(innercv) == SVt_PVCV) {
2363 /* XXX 0afba48f added code here to check for a proto CV
2364 attached to the pad entry by magic. But shortly there-
2365 after 81df9f6f95 moved the magic to the pad name. The
2366 code here was never updated, so it wasn’t doing anything
2367 and got deleted when PADNAME became a distinct type. Is
2368 there any bug as a result? */
2369 if (CvOUTSIDE(innercv) == old_cv) {
2370 if (!CvWEAKOUTSIDE(innercv)) {
2371 SvREFCNT_dec(old_cv);
2372 SvREFCNT_inc_simple_void_NN(new_cv);
2374 CvOUTSIDE(innercv) = new_cv;
2377 else { /* format reference */
2378 SV * const rv = curpad[ix];
2380 if (!SvOK(rv)) continue;
2382 assert(SvWEAKREF(rv));
2383 innercv = (CV *)SvRV(rv);
2384 assert(!CvWEAKOUTSIDE(innercv));
2385 assert(CvOUTSIDE(innercv) == old_cv);
2386 SvREFCNT_dec(CvOUTSIDE(innercv));
2387 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2394 =for apidoc pad_push
2396 Push a new pad frame onto the padlist, unless there's already a pad at
2397 this depth, in which case don't bother creating a new one. Then give
2398 the new pad an C<@_> in slot zero.
2404 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2406 PERL_ARGS_ASSERT_PAD_PUSH;
2408 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2409 PAD** const svp = PadlistARRAY(padlist);
2410 AV* const newpad = newAV();
2411 SV** const oldpad = AvARRAY(svp[depth-1]);
2412 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2413 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2414 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2417 Newxz( AvALLOC(newpad), ix + 1, SV *);
2418 AvARRAY(newpad) = AvALLOC(newpad);
2419 AvMAX(newpad) = AvFILLp(newpad) = ix;
2421 for ( ;ix > 0; ix--) {
2423 if (names_fill >= ix && PadnameLEN(names[ix])) {
2424 const char sigil = PadnamePV(names[ix])[0];
2425 if (PadnameOUTER(names[ix])
2426 || PadnameIsSTATE(names[ix])
2429 /* outer lexical or anon code */
2430 sv = SvREFCNT_inc(oldpad[ix]);
2432 else { /* our own lexical */
2434 sv = MUTABLE_SV(newAV());
2435 else if (sigil == '%')
2436 sv = MUTABLE_SV(newHV());
2441 else if (PadnamePV(names[ix])) {
2442 sv = SvREFCNT_inc_NN(oldpad[ix]);
2445 /* save temporaries on recursion? */
2449 AvARRAY(newpad)[ix] = sv;
2452 AvARRAY(newpad)[0] = MUTABLE_SV(av);
2455 padlist_store(padlist, depth, newpad);
2459 #if defined(USE_ITHREADS)
2461 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2464 =for apidoc padlist_dup
2472 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2478 PERL_ARGS_ASSERT_PADLIST_DUP;
2480 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2481 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2483 max = cloneall ? PadlistMAX(srcpad) : 1;
2485 Newx(dstpad, 1, PADLIST);
2486 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2487 PadlistMAX(dstpad) = max;
2488 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2490 PadlistARRAY(dstpad)[0] = (PAD *)
2491 padnamelist_dup(PadlistNAMES(srcpad), param);
2492 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2495 for (depth = 1; depth <= max; ++depth)
2496 PadlistARRAY(dstpad)[depth] =
2497 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2499 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2500 to build anything other than the first level of pads. */
2501 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2503 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2504 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2505 SV **oldpad = AvARRAY(srcpad1);
2506 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2512 av_extend(pad1, ix);
2513 PadlistARRAY(dstpad)[1] = pad1;
2514 pad1a = AvARRAY(pad1);
2519 for ( ;ix > 0; ix--) {
2522 } else if (names_fill >= ix && names[ix] &&
2523 PadnameLEN(names[ix])) {
2524 const char sigil = PadnamePV(names[ix])[0];
2525 if (PadnameOUTER(names[ix])
2526 || PadnameIsSTATE(names[ix])
2529 /* outer lexical or anon code */
2530 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2532 else { /* our own lexical */
2533 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2534 /* This is a work around for how the current
2535 implementation of ?{ } blocks in regexps
2536 interacts with lexicals. */
2537 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2542 sv = MUTABLE_SV(newAV());
2543 else if (sigil == '%')
2544 sv = MUTABLE_SV(newHV());
2551 else if (( names_fill >= ix && names[ix]
2552 && PadnamePV(names[ix]) )) {
2553 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2556 /* save temporaries on recursion? */
2557 SV * const sv = newSV(0);
2560 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2561 FIXTHAT before merging this branch.
2562 (And I know how to) */
2563 if (SvPADTMP(oldpad[ix]))
2569 args = newAV(); /* Will be @_ */
2571 pad1a[0] = (SV *)args;
2579 #endif /* USE_ITHREADS */
2582 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2585 SSize_t const oldmax = PadlistMAX(padlist);
2587 PERL_ARGS_ASSERT_PADLIST_STORE;
2591 if (key > PadlistMAX(padlist)) {
2592 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2593 (SV ***)&PadlistARRAY(padlist),
2594 (SV ***)&PadlistARRAY(padlist));
2595 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2598 ary = PadlistARRAY(padlist);
2599 SvREFCNT_dec(ary[key]);
2605 =for apidoc newPADNAMELIST
2607 Creates a new pad name list. C<max> is the highest index for which space
2614 Perl_newPADNAMELIST(size_t max)
2617 Newx(pnl, 1, PADNAMELIST);
2618 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2619 PadnamelistMAX(pnl) = -1;
2620 PadnamelistREFCNT(pnl) = 1;
2621 PadnamelistMAXNAMED(pnl) = 0;
2622 pnl->xpadnl_max = max;
2627 =for apidoc padnamelist_store
2629 Stores the pad name (which may be null) at the given index, freeing any
2630 existing pad name in that slot.
2636 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2640 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2644 if (key > pnl->xpadnl_max)
2645 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2646 (SV ***)&PadnamelistARRAY(pnl),
2647 (SV ***)&PadnamelistARRAY(pnl));
2648 if (PadnamelistMAX(pnl) < key) {
2649 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2650 key-PadnamelistMAX(pnl), PADNAME *);
2651 PadnamelistMAX(pnl) = key;
2653 ary = PadnamelistARRAY(pnl);
2655 PadnameREFCNT_dec(ary[key]);
2661 =for apidoc padnamelist_fetch
2663 Fetches the pad name from the given index.
2669 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2671 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2674 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2678 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2680 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2681 if (!--PadnamelistREFCNT(pnl)) {
2682 while(PadnamelistMAX(pnl) >= 0)
2684 PADNAME * const pn =
2685 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2687 PadnameREFCNT_dec(pn);
2689 Safefree(PadnamelistARRAY(pnl));
2694 #if defined(USE_ITHREADS)
2697 =for apidoc padnamelist_dup
2699 Duplicates a pad name list.
2705 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2707 PADNAMELIST *dstpad;
2708 SSize_t max = PadnamelistMAX(srcpad);
2710 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2712 /* look for it in the table first */
2713 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2717 dstpad = newPADNAMELIST(max);
2718 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2719 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2720 PadnamelistMAX(dstpad) = max;
2722 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2723 for (; max >= 0; max--)
2724 if (PadnamelistARRAY(srcpad)[max]) {
2725 PadnamelistARRAY(dstpad)[max] =
2726 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2727 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2733 #endif /* USE_ITHREADS */
2736 =for apidoc newPADNAMEpvn
2738 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2739 use this for pad names that point to outer lexicals. See
2740 C<L</newPADNAMEouter>>.
2746 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2748 struct padname_with_str *alloc;
2749 char *alloc2; /* for Newxz */
2751 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2753 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2755 alloc = (struct padname_with_str *)alloc2;
2756 pn = (PADNAME *)alloc;
2757 PadnameREFCNT(pn) = 1;
2758 PadnamePV(pn) = alloc->xpadn_str;
2759 Copy(s, PadnamePV(pn), len, char);
2760 *(PadnamePV(pn) + len) = '\0';
2761 PadnameLEN(pn) = len;
2766 =for apidoc newPADNAMEouter
2768 Constructs and returns a new pad name. Only use this function for names
2769 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2770 the outer pad name that this one mirrors. The returned pad name has the
2771 C<PADNAMEt_OUTER> flag already set.
2773 =for apidoc Amnh||PADNAMEt_OUTER
2779 Perl_newPADNAMEouter(PADNAME *outer)
2782 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2783 Newxz(pn, 1, PADNAME);
2784 PadnameREFCNT(pn) = 1;
2785 PadnamePV(pn) = PadnamePV(outer);
2786 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2787 another entry. The original pad name owns the buffer. */
2788 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2789 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2790 PadnameLEN(pn) = PadnameLEN(outer);
2795 Perl_padname_free(pTHX_ PADNAME *pn)
2797 PERL_ARGS_ASSERT_PADNAME_FREE;
2798 if (!--PadnameREFCNT(pn)) {
2799 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2800 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2803 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2804 SvREFCNT_dec(PadnameOURSTASH(pn));
2805 if (PadnameOUTER(pn))
2806 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2811 #if defined(USE_ITHREADS)
2814 =for apidoc padname_dup
2816 Duplicates a pad name.
2822 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2826 PERL_ARGS_ASSERT_PADNAME_DUP;
2828 /* look for it in the table first */
2829 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2833 if (!PadnamePV(src)) {
2834 dst = &PL_padname_undef;
2835 ptr_table_store(PL_ptr_table, src, dst);
2839 dst = PadnameOUTER(src)
2840 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2841 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2842 ptr_table_store(PL_ptr_table, src, dst);
2843 PadnameLEN(dst) = PadnameLEN(src);
2844 PadnameFLAGS(dst) = PadnameFLAGS(src);
2845 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2846 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2847 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2849 dst->xpadn_low = src->xpadn_low;
2850 dst->xpadn_high = src->xpadn_high;
2851 dst->xpadn_gen = src->xpadn_gen;
2855 #endif /* USE_ITHREADS */
2858 * ex: set ts=8 sts=4 sw=4 et: