3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 * As of Sept 2002, this file is new and may be in a state of flux for
23 * a while. I've marked things I intent to come back and look at further
24 * with an 'XXX DAPM' comment.
28 =head1 Pad Data Structures
30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
32 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing). Require'd files are simply evals without any outer lexical
41 XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
44 determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
45 internal purpose in XSUBs.
47 The PADLIST has a C array where pads are stored.
49 The 0th entry of the PADLIST is a PADNAMELIST
50 which represents the "names" or rather
51 the "static type information" for lexicals. The individual elements of a
52 PADNAMELIST are PADNAMEs. Future
53 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
54 array, so don't rely on it. See L</PadlistNAMES>.
56 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
57 at that depth of recursion into the CV. The 0th slot of a frame AV is an
58 AV which is @_. Other entries are storage for variables and op targets.
60 Iterating over the PADNAMELIST iterates over all possible pad
61 items. Pad slots for targets (SVs_PADTMP)
62 and GVs end up having &PL_padname_undef "names", while slots for constants
63 have &PL_padname_const "names" (see pad_alloc()). That &PL_padname_undef
64 and &PL_padname_const are used is an implementation detail subject to
65 change. To test for them, use C<!PadnamePV(name)> and C<PadnamePV(name)
66 && !PadnameLEN(name)>, respectively.
68 Only my/our variable slots get valid names.
69 The rest are op targets/GVs/constants which are statically allocated
70 or resolved at compile time. These don't have names by which they
71 can be looked up from Perl code at run time through eval"" the way
72 my/our variables can be. Since they can't be looked up by "name"
73 but only by their index allocated at compile time (which is usually
74 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
76 The pad names in the PADNAMELIST have their PV holding the name of
77 the variable. The COP_SEQ_RANGE_LOW and _HIGH fields form a range
78 (low+1..high inclusive) of cop_seq numbers for which the name is
79 valid. During compilation, these fields may hold the special value
80 PERL_PADSEQ_INTRO to indicate various stages:
82 COP_SEQ_RANGE_LOW _HIGH
83 ----------------- -----
84 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
85 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
86 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
88 For typed lexicals PadnameTYPE points at the type stash. For C<our>
89 lexicals, PadnameOURSTASH points at the stash of the associated global (so
90 that duplicate C<our> declarations in the same package can be detected).
91 PadnameGEN is sometimes used to store the generation number during
94 If PadnameOUTER is set on the pad name, then that slot in the frame AV
95 is a REFCNT'ed reference to a lexical from "outside". Such entries
96 are sometimes referred to as 'fake'. In this case, the name does not
97 use 'low' and 'high' to store a cop_seq range, since it is in scope
98 throughout. Instead 'high' stores some flags containing info about
99 the real lexical (is it declared in an anon, and is it capable of being
100 instantiated multiple times?), and for fake ANONs, 'low' contains the index
101 within the parent's pad where the lexical's value is stored, to make
104 If the 'name' is '&' the corresponding entry in the PAD
105 is a CV representing a possible closure.
107 Note that formats are treated as anon subs, and are cloned each time
108 write is called (if necessary).
110 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
111 and set on scope exit. This allows the
112 'Variable $x is not available' warning
113 to be generated in evals, such as
115 { my $x = 1; sub f { eval '$x'} } f();
117 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised',
118 but this internal state is stored in a separate pad entry.
120 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
122 During compilation, this points to the array containing the names part
123 of the pad for the currently-compiling code.
125 =for apidoc AmxU|PAD *|PL_comppad
127 During compilation, this points to the array containing the values
128 part of the pad for the currently-compiling code. (At runtime a CV may
129 have many such value arrays; at compile time just one is constructed.)
130 At runtime, this points to the array containing the currently-relevant
131 values for the pad for the currently-executing code.
133 =for apidoc AmxU|SV **|PL_curpad
135 Points directly to the body of the L</PL_comppad> array.
136 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
143 #define PERL_IN_PAD_C
145 #include "keywords.h"
147 #define COP_SEQ_RANGE_LOW_set(sv,val) \
148 STMT_START { (sv)->xpadn_low = (val); } STMT_END
149 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
150 STMT_START { (sv)->xpadn_high = (val); } STMT_END
152 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
153 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
157 Perl_set_padlist(CV * cv, PADLIST *padlist){
158 PERL_ARGS_ASSERT_SET_PADLIST;
160 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
162 assert((Size_t)padlist != UINT64_C(0xEFEFEFEF));
164 # error unknown pointer size
166 assert(!CvISXSUB(cv));
167 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
172 =for apidoc Am|PADLIST *|pad_new|int flags
174 Create a new padlist, updating the global variables for the
175 currently-compiling padlist to point to the new padlist. The following
176 flags can be OR'ed together:
178 padnew_CLONE this pad is for a cloned CV
179 padnew_SAVE save old globals on the save stack
180 padnew_SAVESUB also save extra stuff for start of sub
186 Perl_pad_new(pTHX_ int flags)
189 PADNAMELIST *padname;
193 ASSERT_CURPAD_LEGAL("pad_new");
195 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
196 * vars (based on flags) rather than storing vals + addresses for
197 * each individually. Also see pad_block_start.
198 * XXX DAPM Try to see whether all these conditionals are required
201 /* save existing state, ... */
203 if (flags & padnew_SAVE) {
205 if (! (flags & padnew_CLONE)) {
206 SAVESPTR(PL_comppad_name);
208 SAVEI32(PL_constpadix);
209 SAVEI32(PL_comppad_name_fill);
210 SAVEI32(PL_min_intro_pending);
211 SAVEI32(PL_max_intro_pending);
212 SAVEBOOL(PL_cv_has_eval);
213 if (flags & padnew_SAVESUB) {
214 SAVEBOOL(PL_pad_reset_pending);
218 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
219 * saved - check at some pt that this is okay */
221 /* ... create new pad ... */
223 Newxz(padlist, 1, PADLIST);
226 if (flags & padnew_CLONE) {
227 /* XXX DAPM I dont know why cv_clone needs it
228 * doing differently yet - perhaps this separate branch can be
229 * dispensed with eventually ???
232 AV * const a0 = newAV(); /* will be @_ */
233 av_store(pad, 0, MUTABLE_SV(a0));
236 PadnamelistREFCNT(padname = PL_comppad_name)++;
239 padlist->xpadl_id = PL_padlist_generation++;
240 av_store(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 =head1 Embedding Functions
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 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,
394 /* XXX DAPM for efficiency, we should only do this if we know we have
395 * children, or integrate this loop with general cleanup */
397 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
398 CV * const outercv = CvOUTSIDE(&cvbody);
399 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
400 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
401 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
402 PAD * const comppad = PadlistARRAY(padlist)[1];
403 SV ** const curpad = AvARRAY(comppad);
404 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
405 PADNAME * const name = namepad[ix];
406 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
408 CV * const innercv = MUTABLE_CV(curpad[ix]);
409 U32 inner_rc = SvREFCNT(innercv);
411 assert(SvTYPE(innercv) != SVt_PVFM);
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 (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 CvROOT attached, it has
492 finished its job, so it can forget the slab.
498 Perl_cv_forget_slab(pTHX_ CV *cv)
500 const bool slabbed = !!CvSLABBED(cv);
503 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
505 if (!slabbed) return;
509 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
510 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
512 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
516 #ifdef PERL_DEBUG_READONLY_OPS
517 const size_t refcnt = slab->opslab_refcnt;
519 OpslabREFCNT_dec(slab);
520 #ifdef PERL_DEBUG_READONLY_OPS
521 if (refcnt > 1) Slab_to_ro(slab);
527 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
529 Allocates a place in the currently-compiling
530 pad (via L<perlapi/pad_alloc>) and
531 then stores a name for that entry. I<name> is adopted and
532 becomes the name entry; it must already contain the name
533 string. I<typestash> and I<ourstash> and the C<padadd_STATE>
534 flag get added to I<name>. None of the other
535 processing of L<perlapi/pad_add_name_pvn>
536 is done. Returns the offset of the allocated pad slot.
542 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
545 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
547 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
549 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
552 SvPAD_TYPED_on(name);
554 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
558 SvOURSTASH_set(name, ourstash);
559 SvREFCNT_inc_simple_void_NN(ourstash);
561 else if (flags & padadd_STATE) {
562 SvPAD_STATE_on(name);
565 padnamelist_store(PL_comppad_name, offset, name);
566 if (PadnameLEN(name) > 1)
567 PadnamelistMAXNAMED(PL_comppad_name) = offset;
572 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
574 Allocates a place in the currently-compiling pad for a named lexical
575 variable. Stores the name and other metadata in the name part of the
576 pad, and makes preparations to manage the variable's lexical scoping.
577 Returns the offset of the allocated pad slot.
579 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
580 If I<typestash> is non-null, the name is for a typed lexical, and this
581 identifies the type. If I<ourstash> is non-null, it's a lexical reference
582 to a package variable, and this identifies the package. The following
583 flags can be OR'ed together:
585 padadd_OUR redundantly specifies if it's a package var
586 padadd_STATE variable will retain value persistently
587 padadd_NO_DUP_CHECK skip check for lexical shadowing
593 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
594 U32 flags, HV *typestash, HV *ourstash)
599 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
601 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
602 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
605 name = newPADNAMEpvn(namepv, namelen);
607 if ((flags & padadd_NO_DUP_CHECK) == 0) {
609 SAVEFREEPADNAME(name); /* in case of fatal warnings */
610 /* check for duplicate declaration */
611 pad_check_dup(name, flags & padadd_OUR, ourstash);
612 PadnameREFCNT(name)++;
616 offset = pad_alloc_name(name, flags, typestash, ourstash);
618 /* not yet introduced */
619 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
620 COP_SEQ_RANGE_HIGH_set(name, 0);
622 if (!PL_min_intro_pending)
623 PL_min_intro_pending = offset;
624 PL_max_intro_pending = offset;
625 /* if it's not a simple scalar, replace with an AV or HV */
626 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
627 assert(SvREFCNT(PL_curpad[offset]) == 1);
628 if (namelen != 0 && *namepv == '@')
629 sv_upgrade(PL_curpad[offset], SVt_PVAV);
630 else if (namelen != 0 && *namepv == '%')
631 sv_upgrade(PL_curpad[offset], SVt_PVHV);
632 else if (namelen != 0 && *namepv == '&')
633 sv_upgrade(PL_curpad[offset], SVt_PVCV);
634 assert(SvPADMY(PL_curpad[offset]));
635 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
636 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
637 (long)offset, PadnamePV(name),
638 PTR2UV(PL_curpad[offset])));
644 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
646 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
647 instead of a string/length pair.
653 Perl_pad_add_name_pv(pTHX_ const char *name,
654 const U32 flags, HV *typestash, HV *ourstash)
656 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
657 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
661 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
663 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
664 of an SV instead of a string/length pair.
670 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
674 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
675 namepv = SvPVutf8(name, namelen);
676 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
680 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
682 Allocates a place in the currently-compiling pad,
683 returning the offset of the allocated pad slot.
684 No name is initially attached to the pad slot.
685 I<tmptype> is a set of flags indicating the kind of pad entry required,
686 which will be set in the value SV for the allocated pad entry:
688 SVs_PADMY named lexical variable ("my", "our", "state")
689 SVs_PADTMP unnamed temporary store
690 SVf_READONLY constant shared between recursion levels
692 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
693 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
694 does not cause the SV in the pad slot to be marked read-only, but simply
695 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
696 least should be treated as such.
698 I<optype> should be an opcode indicating the type of operation that the
699 pad entry is to support. This doesn't affect operational semantics,
700 but is used for debugging.
705 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
706 * or at least rationalise ??? */
709 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
714 PERL_UNUSED_ARG(optype);
715 ASSERT_CURPAD_ACTIVE("pad_alloc");
717 if (AvARRAY(PL_comppad) != PL_curpad)
718 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
719 AvARRAY(PL_comppad), PL_curpad);
720 if (PL_pad_reset_pending)
722 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
723 /* For a my, simply push a null SV onto the end of PL_comppad. */
724 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
725 retval = AvFILLp(PL_comppad);
728 /* For a tmp, scan the pad from PL_padix upwards
729 * for a slot which has no name and no active value.
730 * For a constant, likewise, but use PL_constpadix.
732 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
733 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
734 const bool konst = cBOOL(tmptype & SVf_READONLY);
735 retval = konst ? PL_constpadix : PL_padix;
738 * Entries that close over unavailable variables
739 * in outer subs contain values not marked PADMY.
740 * Thus we must skip, not just pad values that are
741 * marked as current pad values, but also those with names.
742 * If pad_reset is enabled, ‘current’ means different
743 * things depending on whether we are allocating a con-
744 * stant or a target. For a target, things marked PADTMP
745 * can be reused; not so for constants.
748 if (++retval <= names_fill &&
749 (pn = names[retval]) && PadnamePV(pn))
751 sv = *av_fetch(PL_comppad, retval, TRUE);
754 (konst ? SVs_PADTMP : 0))
762 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
763 tmptype &= ~SVf_READONLY;
764 tmptype |= SVs_PADTMP;
766 *(konst ? &PL_constpadix : &PL_padix) = retval;
768 SvFLAGS(sv) |= tmptype;
769 PL_curpad = AvARRAY(PL_comppad);
771 DEBUG_X(PerlIO_printf(Perl_debug_log,
772 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
773 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
774 PL_op_name[optype]));
775 #ifdef DEBUG_LEAKING_SCALARS
776 sv->sv_debug_optype = optype;
777 sv->sv_debug_inpad = 1;
779 return (PADOFFSET)retval;
783 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
785 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
786 for an anonymous function that is lexically scoped inside the
787 currently-compiling function.
788 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
789 to the outer scope is weakened to avoid a reference loop.
791 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
793 I<optype> should be an opcode indicating the type of operation that the
794 pad entry is to support. This doesn't affect operational semantics,
795 but is used for debugging.
801 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
804 PADNAME * const name = newPADNAMEpvn("&", 1);
806 PERL_ARGS_ASSERT_PAD_ADD_ANON;
807 assert (SvTYPE(func) == SVt_PVCV);
810 /* These two aren't used; just make sure they're not equal to
811 * PERL_PADSEQ_INTRO. They should be 0 by default. */
812 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
813 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
814 ix = pad_alloc(optype, SVs_PADMY);
815 padnamelist_store(PL_comppad_name, ix, name);
816 /* XXX DAPM use PL_curpad[] ? */
817 av_store(PL_comppad, ix, (SV*)func);
819 /* to avoid ref loops, we never have parent + child referencing each
820 * other simultaneously */
821 if (CvOUTSIDE(func)) {
822 assert(!CvWEAKOUTSIDE(func));
823 CvWEAKOUTSIDE_on(func);
824 SvREFCNT_dec_NN(CvOUTSIDE(func));
830 Perl_pad_add_weakref(pTHX_ CV* func)
832 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
833 PADNAME * const name = newPADNAMEpvn("&", 1);
834 SV * const rv = newRV_inc((SV *)func);
836 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
838 /* These two aren't used; just make sure they're not equal to
839 * PERL_PADSEQ_INTRO. They should be 0 by default. */
840 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
841 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
842 padnamelist_store(PL_comppad_name, ix, name);
844 av_store(PL_comppad, ix, rv);
848 =for apidoc pad_check_dup
850 Check for duplicate declarations: report any of:
852 * a my in the current scope with the same name;
853 * an our (anywhere in the pad) with the same name and the
854 same stash as C<ourstash>
856 C<is_our> indicates that the name to check is an 'our' declaration.
862 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
866 const U32 is_our = flags & padadd_OUR;
868 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
870 ASSERT_CURPAD_ACTIVE("pad_check_dup");
872 assert((flags & ~padadd_OUR) == 0);
874 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
875 return; /* nothing to check */
877 svp = PadnamelistARRAY(PL_comppad_name);
878 top = PadnamelistMAX(PL_comppad_name);
879 /* check the current scope */
880 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
882 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
883 PADNAME * const sv = svp[off];
885 && PadnameLEN(sv) == PadnameLEN(name)
887 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
888 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
889 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
891 if (is_our && (SvPAD_OUR(sv)))
892 break; /* "our" masking "our" */
893 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
894 Perl_warner(aTHX_ packWARN(WARN_MISC),
895 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
896 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
897 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
899 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
900 ? "scope" : "statement"));
905 /* check the rest of the pad */
908 PADNAME * const sv = svp[off];
910 && PadnameLEN(sv) == PadnameLEN(name)
912 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
913 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
914 && SvOURSTASH(sv) == ourstash
915 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
917 Perl_warner(aTHX_ packWARN(WARN_MISC),
918 "\"our\" variable %"PNf" redeclared", PNfARG(sv));
919 if ((I32)off <= PL_comppad_name_floor)
920 Perl_warner(aTHX_ packWARN(WARN_MISC),
921 "\t(Did you mean \"local\" instead of \"our\"?)\n");
931 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
933 Given the name of a lexical variable, find its position in the
934 currently-compiling pad.
935 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
936 I<flags> is reserved and must be zero.
937 If it is not in the current pad but appears in the pad of any lexically
938 enclosing scope, then a pseudo-entry for it is added in the current pad.
939 Returns the offset in the current pad,
940 or C<NOT_IN_PAD> if no such lexical is in scope.
946 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
951 const PADNAMELIST *namelist;
954 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
956 pad_peg("pad_findmy_pvn");
959 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
962 offset = pad_findlex(namepv, namelen, flags,
963 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
964 if ((PADOFFSET)offset != NOT_IN_PAD)
967 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
969 if (*namepv == '&') return NOT_IN_PAD;
971 /* look for an our that's being introduced; this allows
972 * our $foo = 0 unless defined $foo;
973 * to not give a warning. (Yes, this is a hack) */
975 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
976 name_p = PadnamelistARRAY(namelist);
977 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
978 const PADNAME * const name = name_p[offset];
979 if (name && PadnameLEN(name) == namelen
980 && !PadnameOUTER(name)
981 && (PadnameIsOUR(name))
982 && ( PadnamePV(name) == namepv
983 || memEQ(PadnamePV(name), namepv, namelen) )
984 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
992 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
994 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
995 instead of a string/length pair.
1001 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1003 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1004 return pad_findmy_pvn(name, strlen(name), flags);
1008 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1010 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1011 of an SV instead of a string/length pair.
1017 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1021 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1022 namepv = SvPVutf8(name, namelen);
1023 return pad_findmy_pvn(namepv, namelen, flags);
1027 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1029 Find the position of the lexical C<$_> in the pad of the
1030 currently-executing function. Returns the offset in the current pad,
1031 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1032 the global one should be used instead).
1033 L</find_rundefsv> is likely to be more convenient.
1039 Perl_find_rundefsvoffset(pTHX)
1043 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1044 NULL, &out_pn, &out_flags);
1048 =for apidoc Am|SV *|find_rundefsv
1050 Find and return the variable that is named C<$_> in the lexical scope
1051 of the currently-executing function. This may be a lexical C<$_>,
1052 or will otherwise be the global one.
1058 Perl_find_rundefsv(pTHX)
1064 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1065 NULL, &name, &flags);
1067 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1074 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1080 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1082 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1083 NULL, &name, &flags);
1085 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1088 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1092 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
1094 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1095 in the inner pads if it's found in an outer one.
1097 Returns the offset in the bottom pad of the lex or the fake lex.
1098 cv is the CV in which to start the search, and seq is the current cop_seq
1099 to match against. If warn is true, print appropriate warnings. The out_*
1100 vars return values, and so are pointers to where the returned values
1101 should be stored. out_capture, if non-null, requests that the innermost
1102 instance of the lexical is captured; out_name is set to the innermost
1103 matched pad name or fake pad name; out_flags returns the flags normally
1104 associated with the PARENT_FAKELEX_FLAGS field of a fake pad name.
1106 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1107 then comes back down, adding fake entries
1108 as it goes. It has to be this way
1109 because fake names in anon protoypes have to store in xlow the index into
1115 /* the CV has finished being compiled. This is not a sufficient test for
1116 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1117 #define CvCOMPILED(cv) CvROOT(cv)
1119 /* the CV does late binding of its lexicals */
1120 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1123 S_unavailable(pTHX_ PADNAME *name)
1125 /* diag_listed_as: Variable "%s" is not available */
1126 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1127 "%se \"%"PNf"\" is not available",
1128 *PadnamePV(name) == '&'
1135 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1136 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1138 I32 offset, new_offset;
1141 const PADLIST * const padlist = CvPADLIST(cv);
1142 const bool staleok = !!(flags & padadd_STALEOK);
1144 PERL_ARGS_ASSERT_PAD_FINDLEX;
1146 flags &= ~ padadd_STALEOK; /* one-shot flag */
1148 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1153 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1154 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1155 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1156 out_capture ? " capturing" : "" ));
1158 /* first, search this pad */
1160 if (padlist) { /* not an undef CV */
1161 I32 fake_offset = 0;
1162 const PADNAMELIST * const names = PadlistNAMES(padlist);
1163 PADNAME * const * const name_p = PadnamelistARRAY(names);
1165 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1166 const PADNAME * const name = name_p[offset];
1167 if (name && PadnameLEN(name) == namelen
1168 && ( PadnamePV(name) == namepv
1169 || memEQ(PadnamePV(name), namepv, namelen) ))
1171 if (PadnameOUTER(name)) {
1172 fake_offset = offset; /* in case we don't find a real one */
1175 if (PadnameIN_SCOPE(name, seq))
1180 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1181 if (offset > 0) { /* not fake */
1183 *out_name = name_p[offset]; /* return the name */
1185 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1186 * instances. For now, we just test !CvUNIQUE(cv), but
1187 * ideally, we should detect my's declared within loops
1188 * etc - this would allow a wider range of 'not stayed
1189 * shared' warnings. We also treated already-compiled
1190 * lexes as not multi as viewed from evals. */
1192 *out_flags = CvANON(cv) ?
1194 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1195 ? PAD_FAKELEX_MULTI : 0;
1197 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1198 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1199 PTR2UV(cv), (long)offset,
1200 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1201 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1203 else { /* fake match */
1204 offset = fake_offset;
1205 *out_name = name_p[offset]; /* return the name */
1206 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1207 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1208 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1209 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1210 (unsigned long) PARENT_PAD_INDEX(*out_name)
1214 /* return the lex? */
1219 if (PadnameIsOUR(*out_name)) {
1220 *out_capture = NULL;
1224 /* trying to capture from an anon prototype? */
1226 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1227 : *out_flags & PAD_FAKELEX_ANON)
1233 *out_capture = NULL;
1239 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1240 && !PadnameIsSTATE(name_p[offset])
1241 && warn && ckWARN(WARN_CLOSURE)) {
1243 /* diag_listed_as: Variable "%s" will not stay
1245 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1246 "%se \"%"UTF8f"\" will not stay shared",
1247 *namepv == '&' ? "Subroutin" : "Variabl",
1248 UTF8fARG(1, namelen, namepv));
1251 if (fake_offset && CvANON(cv)
1252 && CvCLONE(cv) &&!CvCLONED(cv))
1255 /* not yet caught - look further up */
1256 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1257 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1260 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1262 newwarn, out_capture, out_name, out_flags);
1267 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1268 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1269 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1270 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1271 PTR2UV(cv), PTR2UV(*out_capture)));
1273 if (SvPADSTALE(*out_capture)
1274 && (!CvDEPTH(cv) || !staleok)
1275 && !PadnameIsSTATE(name_p[offset]))
1279 *out_capture = NULL;
1282 if (!*out_capture) {
1283 if (namelen != 0 && *namepv == '@')
1284 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1285 else if (namelen != 0 && *namepv == '%')
1286 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1287 else if (namelen != 0 && *namepv == '&')
1288 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1290 *out_capture = sv_newmortal();
1298 /* it's not in this pad - try above */
1303 /* out_capture non-null means caller wants us to capture lex; in
1304 * addition we capture ourselves unless it's an ANON/format */
1305 new_capturep = out_capture ? out_capture :
1306 CvLATE(cv) ? NULL : &new_capture;
1308 offset = pad_findlex(namepv, namelen,
1309 flags | padadd_STALEOK*(new_capturep == &new_capture),
1310 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1311 new_capturep, out_name, out_flags);
1312 if ((PADOFFSET)offset == NOT_IN_PAD)
1315 /* found in an outer CV. Add appropriate fake entry to this pad */
1317 /* don't add new fake entries (via eval) to CVs that we have already
1318 * finished compiling, or to undef CVs */
1319 if (CvCOMPILED(cv) || !padlist)
1320 return 0; /* this dummy (and invalid) value isnt used by the caller */
1323 PADNAME *new_name = newPADNAMEouter(*out_name);
1324 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1325 PAD * const ocomppad = PL_comppad;
1326 PL_comppad_name = PadlistNAMES(padlist);
1327 PL_comppad = PadlistARRAY(padlist)[1];
1328 PL_curpad = AvARRAY(PL_comppad);
1331 = pad_alloc_name(new_name,
1332 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1333 PadnameTYPE(*out_name),
1334 PadnameOURSTASH(*out_name)
1337 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1338 "Pad addname: %ld \"%.*s\" FAKE\n",
1340 (int) PadnameLEN(new_name),
1341 PadnamePV(new_name)));
1342 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1344 PARENT_PAD_INDEX_set(new_name, 0);
1345 if (PadnameIsOUR(new_name)) {
1346 NOOP; /* do nothing */
1348 else if (CvLATE(cv)) {
1349 /* delayed creation - just note the offset within parent pad */
1350 PARENT_PAD_INDEX_set(new_name, offset);
1354 /* immediate creation - capture outer value right now */
1355 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1356 /* But also note the offset, as newMYSUB needs it */
1357 PARENT_PAD_INDEX_set(new_name, offset);
1358 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1359 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1360 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1362 *out_name = new_name;
1363 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1365 PL_comppad_name = ocomppad_name;
1366 PL_comppad = ocomppad;
1367 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1375 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1377 Get the value at offset I<po> in the current (compiling or executing) pad.
1378 Use macro PAD_SV instead of calling this function directly.
1384 Perl_pad_sv(pTHX_ PADOFFSET po)
1386 ASSERT_CURPAD_ACTIVE("pad_sv");
1389 Perl_croak(aTHX_ "panic: pad_sv po");
1390 DEBUG_X(PerlIO_printf(Perl_debug_log,
1391 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1392 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1394 return PL_curpad[po];
1398 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1400 Set the value at offset I<po> in the current (compiling or executing) pad.
1401 Use the macro PAD_SETSV() rather than calling this function directly.
1407 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1409 PERL_ARGS_ASSERT_PAD_SETSV;
1411 ASSERT_CURPAD_ACTIVE("pad_setsv");
1413 DEBUG_X(PerlIO_printf(Perl_debug_log,
1414 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1415 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1420 #endif /* DEBUGGING */
1423 =for apidoc m|void|pad_block_start|int full
1425 Update the pad compilation state variables on entry to a new block.
1430 /* XXX DAPM perhaps:
1431 * - integrate this in general state-saving routine ???
1432 * - combine with the state-saving going on in pad_new ???
1433 * - introduce a new SAVE type that does all this in one go ?
1437 Perl_pad_block_start(pTHX_ int full)
1439 ASSERT_CURPAD_ACTIVE("pad_block_start");
1440 SAVEI32(PL_comppad_name_floor);
1441 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1443 PL_comppad_name_fill = PL_comppad_name_floor;
1444 if (PL_comppad_name_floor < 0)
1445 PL_comppad_name_floor = 0;
1446 SAVEI32(PL_min_intro_pending);
1447 SAVEI32(PL_max_intro_pending);
1448 PL_min_intro_pending = 0;
1449 SAVEI32(PL_comppad_name_fill);
1450 SAVEI32(PL_padix_floor);
1451 /* PL_padix_floor is what PL_padix is reset to at the start of each
1452 statement, by pad_reset(). We set it when entering a new scope
1453 to keep things like this working:
1454 print "$foo$bar", do { this(); that() . "foo" };
1455 We must not let "$foo$bar" and the later concatenation share the
1457 PL_padix_floor = PL_padix;
1458 PL_pad_reset_pending = FALSE;
1462 =for apidoc Am|U32|intro_my
1464 "Introduce" C<my> variables to visible status. This is called during parsing
1465 at the end of each statement to make lexical variables visible to subsequent
1478 ASSERT_CURPAD_ACTIVE("intro_my");
1479 if (PL_compiling.cop_seq) {
1480 seq = PL_compiling.cop_seq;
1481 PL_compiling.cop_seq = 0;
1484 seq = PL_cop_seqmax;
1485 if (! PL_min_intro_pending)
1488 svp = PadnamelistARRAY(PL_comppad_name);
1489 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1490 PADNAME * const sv = svp[i];
1492 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1493 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1495 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1496 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1497 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1498 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1499 (long)i, PadnamePV(sv),
1500 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1501 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1506 PL_min_intro_pending = 0;
1507 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1508 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1509 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1515 =for apidoc m|void|pad_leavemy
1517 Cleanup at end of scope during compilation: set the max seq number for
1518 lexicals in this scope and warn of any lexicals that never got introduced.
1524 Perl_pad_leavemy(pTHX)
1528 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1530 PL_pad_reset_pending = FALSE;
1532 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1533 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1534 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1535 const PADNAME * const name = svp[off];
1536 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1537 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1538 "%"PNf" never introduced",
1542 /* "Deintroduce" my variables that are leaving with this scope. */
1543 for (off = PadnamelistMAX(PL_comppad_name);
1544 off > PL_comppad_name_fill; off--) {
1545 PADNAME * const sv = svp[off];
1546 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1547 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1549 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1550 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1551 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1552 (long)off, PadnamePV(sv),
1553 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1554 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1556 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1557 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1558 OP *kid = newOP(OP_INTROCV, 0);
1560 o = op_prepend_elem(OP_LINESEQ, kid, o);
1565 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1566 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1571 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1573 Abandon the tmp in the current pad at offset po and replace with a
1580 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1582 ASSERT_CURPAD_LEGAL("pad_swipe");
1585 if (AvARRAY(PL_comppad) != PL_curpad)
1586 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1587 AvARRAY(PL_comppad), PL_curpad);
1588 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1589 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1590 (long)po, (long)AvFILLp(PL_comppad));
1592 DEBUG_X(PerlIO_printf(Perl_debug_log,
1593 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1594 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1597 SvREFCNT_dec(PL_curpad[po]);
1600 /* if pad tmps aren't shared between ops, then there's no need to
1601 * create a new tmp when an existing op is freed */
1602 #ifdef USE_PAD_RESET
1603 PL_curpad[po] = newSV(0);
1604 SvPADTMP_on(PL_curpad[po]);
1606 PL_curpad[po] = NULL;
1608 if (PadnamelistMAX(PL_comppad_name) != -1
1609 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1610 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1611 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1613 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1615 /* Use PL_constpadix here, not PL_padix. The latter may have been
1616 reset by pad_reset. We don’t want pad_alloc to have to scan the
1617 whole pad when allocating a constant. */
1618 if ((I32)po < PL_constpadix)
1619 PL_constpadix = po - 1;
1623 =for apidoc m|void|pad_reset
1625 Mark all the current temporaries for reuse
1630 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1631 * between OPs from different statements. During compilation, at the start
1632 * of each statement pad_reset resets PL_padix back to its previous value.
1633 * When allocating a target, pad_alloc begins its scan through the pad at
1638 #ifdef USE_PAD_RESET
1639 if (AvARRAY(PL_comppad) != PL_curpad)
1640 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1641 AvARRAY(PL_comppad), PL_curpad);
1643 DEBUG_X(PerlIO_printf(Perl_debug_log,
1644 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1645 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1646 (long)PL_padix, (long)PL_padix_floor
1650 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1651 PL_padix = PL_padix_floor;
1654 PL_pad_reset_pending = FALSE;
1658 =for apidoc Amx|void|pad_tidy|padtidy_type type
1660 Tidy up a pad at the end of compilation of the code to which it belongs.
1661 Jobs performed here are: remove most stuff from the pads of anonsub
1662 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1663 the kind of subroutine:
1665 padtidy_SUB ordinary subroutine
1666 padtidy_SUBCLONE prototype for lexical closure
1667 padtidy_FORMAT format
1672 /* XXX DAPM surely most of this stuff should be done properly
1673 * at the right time beforehand, rather than going around afterwards
1674 * cleaning up our mistakes ???
1678 Perl_pad_tidy(pTHX_ padtidy_type type)
1682 ASSERT_CURPAD_ACTIVE("pad_tidy");
1684 /* If this CV has had any 'eval-capable' ops planted in it:
1685 * i.e. it contains any of:
1689 * * use re 'eval'; /$var/
1692 * Then any anon prototypes in the chain of CVs should be marked as
1693 * cloneable, so that for example the eval's CV in
1697 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1698 * potentially have an eval executed within it.
1701 if (PL_cv_has_eval || PL_perldb) {
1703 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1704 if (cv != PL_compcv && CvCOMPILED(cv))
1705 break; /* no need to mark already-compiled code */
1707 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1708 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1715 /* extend namepad to match curpad */
1716 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1717 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1719 if (type == padtidy_SUBCLONE) {
1720 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1723 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1725 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1728 * The only things that a clonable function needs in its
1729 * pad are anonymous subs, constants and GVs.
1730 * The rest are created anew during cloning.
1732 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1735 if (!(PadnamePV(namesv) &&
1736 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1738 SvREFCNT_dec(PL_curpad[ix]);
1739 PL_curpad[ix] = NULL;
1743 else if (type == padtidy_SUB) {
1744 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1745 AV * const av = newAV(); /* Will be @_ */
1746 av_store(PL_comppad, 0, MUTABLE_SV(av));
1750 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1751 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1753 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1754 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1755 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1757 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1758 /* This is a work around for how the current implementation of
1759 ?{ } blocks in regexps interacts with lexicals.
1761 One of our lexicals.
1762 Can't do this on all lexicals, otherwise sub baz() won't
1771 because completion of compiling &bar calling pad_tidy()
1772 would cause (top level) $foo to be marked as stale, and
1773 "no longer available". */
1774 SvPADSTALE_on(PL_curpad[ix]);
1778 PL_curpad = AvARRAY(PL_comppad);
1782 =for apidoc m|void|pad_free|PADOFFSET po
1784 Free the SV at offset po in the current pad.
1789 /* XXX DAPM integrate with pad_swipe ???? */
1791 Perl_pad_free(pTHX_ PADOFFSET po)
1793 #ifndef USE_PAD_RESET
1796 ASSERT_CURPAD_LEGAL("pad_free");
1799 if (AvARRAY(PL_comppad) != PL_curpad)
1800 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1801 AvARRAY(PL_comppad), PL_curpad);
1803 Perl_croak(aTHX_ "panic: pad_free po");
1805 DEBUG_X(PerlIO_printf(Perl_debug_log,
1806 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1807 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1810 #ifndef USE_PAD_RESET
1812 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1813 SvFLAGS(sv) &= ~SVs_PADTMP;
1815 if ((I32)po < PL_padix)
1821 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1823 Dump the contents of a padlist
1829 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1831 const PADNAMELIST *pad_name;
1837 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1842 pad_name = PadlistNAMES(padlist);
1843 pad = PadlistARRAY(padlist)[1];
1844 pname = PadnamelistARRAY(pad_name);
1845 ppad = AvARRAY(pad);
1846 Perl_dump_indent(aTHX_ level, file,
1847 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1848 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1851 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1852 const PADNAME *namesv = pname[ix];
1853 if (namesv && !PadnameLEN(namesv)) {
1857 if (PadnameOUTER(namesv))
1858 Perl_dump_indent(aTHX_ level+1, file,
1859 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1862 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1864 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1865 (unsigned long)PARENT_PAD_INDEX(namesv)
1869 Perl_dump_indent(aTHX_ level+1, file,
1870 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1873 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1874 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1875 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1880 Perl_dump_indent(aTHX_ level+1, file,
1881 "%2d. 0x%"UVxf"<%lu>\n",
1884 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1893 =for apidoc m|void|cv_dump|CV *cv|const char *title
1895 dump the contents of a CV
1901 S_cv_dump(pTHX_ const CV *cv, const char *title)
1903 const CV * const outside = CvOUTSIDE(cv);
1904 PADLIST* const padlist = CvPADLIST(cv);
1906 PERL_ARGS_ASSERT_CV_DUMP;
1908 PerlIO_printf(Perl_debug_log,
1909 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1912 (CvANON(cv) ? "ANON"
1913 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1914 : (cv == PL_main_cv) ? "MAIN"
1915 : CvUNIQUE(cv) ? "UNIQUE"
1916 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1919 : CvANON(outside) ? "ANON"
1920 : (outside == PL_main_cv) ? "MAIN"
1921 : CvUNIQUE(outside) ? "UNIQUE"
1922 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1924 PerlIO_printf(Perl_debug_log,
1925 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1926 do_dump_pad(1, Perl_debug_log, padlist, 1);
1929 #endif /* DEBUGGING */
1932 =for apidoc Am|CV *|cv_clone|CV *proto
1934 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1935 of the function: its code, pad structure, and other attributes.
1936 The prototype is combined with a capture of outer lexicals to which the
1937 code refers, which are taken from the currently-executing instance of
1938 the immediately surrounding code.
1943 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1946 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1950 PADLIST* const protopadlist = CvPADLIST(proto);
1951 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1952 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1953 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1954 SV** const ppad = AvARRAY(protopad);
1955 const I32 fname = PadnamelistMAX(protopad_name);
1956 const I32 fpad = AvFILLp(protopad);
1960 bool trouble = FALSE;
1962 assert(!CvUNIQUE(proto));
1964 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1965 * reliable. The currently-running sub is always the one we need to
1967 * For my subs, the currently-running sub may not be the one we want.
1968 * We have to check whether it is a clone of CvOUTSIDE.
1969 * Note that in general for formats, CvOUTSIDE != find_runcv.
1970 * Since formats may be nested inside closures, CvOUTSIDE may point
1971 * to a prototype; we instead want the cloned parent who called us.
1975 if (CvWEAKOUTSIDE(proto))
1976 outside = find_runcv(NULL);
1978 outside = CvOUTSIDE(proto);
1979 if ((CvCLONE(outside) && ! CvCLONED(outside))
1980 || !CvPADLIST(outside)
1981 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1982 outside = find_runcv_where(
1983 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1985 /* outside could be null */
1989 depth = outside ? CvDEPTH(outside) : 0;
1994 SAVESPTR(PL_compcv);
1996 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1999 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2001 SAVESPTR(PL_comppad_name);
2002 PL_comppad_name = protopad_name;
2003 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
2004 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2006 av_fill(PL_comppad, fpad);
2008 PL_curpad = AvARRAY(PL_comppad);
2010 outpad = outside && CvPADLIST(outside)
2011 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2013 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2015 for (ix = fpad; ix > 0; ix--) {
2016 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
2018 if (namesv && PadnameLEN(namesv)) { /* lexical */
2019 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2023 if (PadnameOUTER(namesv)) { /* lexical from outside? */
2024 /* formats may have an inactive, or even undefined, parent;
2025 but state vars are always available. */
2026 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2027 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2028 && (!outside || !CvDEPTH(outside))) ) {
2029 S_unavailable(aTHX_ namesv);
2033 SvREFCNT_inc_simple_void_NN(sv);
2036 const char sigil = PadnamePV(namesv)[0];
2038 /* If there are state subs, we need to clone them, too.
2039 But they may need to close over variables we have
2040 not cloned yet. So we will have to do a second
2041 pass. Furthermore, there may be state subs clos-
2042 ing over other state subs’ entries, so we have
2043 to put a stub here and then clone into it on the
2045 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2046 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2048 if (CvOUTSIDE(ppad[ix]) != proto)
2050 sv = newSV_type(SVt_PVCV);
2053 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2056 /* Just provide a stub, but name it. It will be
2057 upgrade to the real thing on scope entry. */
2060 PERL_HASH(hash, PadnamePV(namesv)+1,
2061 PadnameLEN(namesv) - 1);
2062 sv = newSV_type(SVt_PVCV);
2065 share_hek(PadnamePV(namesv)+1,
2066 1 - PadnameLEN(namesv),
2071 else sv = SvREFCNT_inc(ppad[ix]);
2072 else if (sigil == '@')
2073 sv = MUTABLE_SV(newAV());
2074 else if (sigil == '%')
2075 sv = MUTABLE_SV(newHV());
2078 /* reset the 'assign only once' flag on each state var */
2079 if (sigil != '&' && SvPAD_STATE(namesv))
2084 else if (namesv && PadnamePV(namesv)) {
2085 sv = SvREFCNT_inc_NN(ppad[ix]);
2096 if (trouble || cloned) {
2097 /* Uh-oh, we have trouble! At least one of the state subs here
2098 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2099 could be pointing to another state protosub that we are
2100 about to clone. So we have to track which sub clones come
2101 from which protosubs. If the CvOUTSIDE pointer for a parti-
2102 cular sub points to something we have not cloned yet, we
2103 delay cloning it. We must loop through the pad entries,
2104 until we get a full pass with no cloning. If any uncloned
2105 subs remain (probably nested inside anonymous or ‘my’ subs),
2106 then they get cloned in a final pass.
2108 bool cloned_in_this_pass;
2110 cloned = (HV *)sv_2mortal((SV *)newHV());
2112 cloned_in_this_pass = FALSE;
2113 for (ix = fpad; ix > 0; ix--) {
2114 PADNAME * const name =
2115 (ix <= fname) ? pname[ix] : NULL;
2116 if (name && name != &PL_padname_undef
2117 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2118 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2120 CV * const protokey = CvOUTSIDE(ppad[ix]);
2121 CV ** const cvp = protokey == proto
2123 : (CV **)hv_fetch(cloned, (char *)&protokey,
2126 S_cv_clone(aTHX_ (CV *)ppad[ix],
2127 (CV *)PL_curpad[ix],
2129 (void)hv_store(cloned, (char *)&ppad[ix],
2131 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2134 cloned_in_this_pass = TRUE;
2138 } while (cloned_in_this_pass);
2140 for (ix = fpad; ix > 0; ix--) {
2141 PADNAME * const name =
2142 (ix <= fname) ? pname[ix] : NULL;
2143 if (name && name != &PL_padname_undef
2144 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2145 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2146 S_cv_clone(aTHX_ (CV *)ppad[ix],
2147 (CV *)PL_curpad[ix],
2148 CvOUTSIDE(ppad[ix]), cloned);
2151 else for (ix = fpad; ix > 0; ix--) {
2152 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2153 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2154 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2155 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2160 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2164 /* Constant sub () { $x } closing over $x:
2165 * The prototype was marked as a candiate for const-ization,
2166 * so try to grab the current const value, and if successful,
2167 * turn into a const sub:
2170 OP *o = CvSTART(cv);
2172 for (; o; o = o->op_next)
2173 if (o->op_type == OP_PADSV)
2175 ASSUME(o->op_type == OP_PADSV);
2176 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2177 /* the candidate should have 1 ref from this pad and 1 ref
2178 * from the parent */
2179 if (const_sv && SvREFCNT(const_sv) == 2) {
2180 const bool was_method = cBOOL(CvMETHOD(cv));
2181 bool copied = FALSE;
2183 PADNAME * const pn =
2184 PadlistNAMESARRAY(CvPADLIST(outside))
2185 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2186 CvPADLIST(cv))[o->op_targ])];
2187 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2189 if (PadnameLVALUE(pn)) {
2190 /* We have a lexical that is potentially modifiable
2191 elsewhere, so making a constant will break clo-
2192 sure behaviour. If this is a ‘simple lexical
2193 op tree’, i.e., sub(){$x}, emit a deprecation
2194 warning, but continue to exhibit the old behav-
2195 iour of making it a constant based on the ref-
2196 count of the candidate variable.
2198 A simple lexical op tree looks like this:
2206 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2210 Perl_ck_warner_d(aTHX_
2211 packWARN(WARN_DEPRECATED),
2212 "Constants from lexical "
2213 "variables potentially "
2214 "modified elsewhere are "
2216 /* We *copy* the lexical variable, and donate the
2217 copy to newCONSTSUB. Yes, this is ugly, and
2218 should be killed. We need to do this for the
2219 time being, however, because turning on SvPADTMP
2220 on a lexical will have observable effects
2222 const_sv = newSVsv(const_sv);
2230 SvREFCNT_inc_simple_void_NN(const_sv);
2231 /* If the lexical is not used elsewhere, it is safe to turn on
2232 SvPADTMP, since it is only when it is used in lvalue con-
2233 text that the difference is observable. */
2234 SvREADONLY_on(const_sv);
2235 SvPADTMP_on(const_sv);
2236 SvREFCNT_dec_NN(cv);
2237 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2251 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2256 const bool newcv = !cv;
2258 assert(!CvUNIQUE(proto));
2260 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2261 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2265 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2268 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2269 else CvGV_set(cv,CvGV(proto));
2270 CvSTASH_set(cv, CvSTASH(proto));
2272 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2274 CvSTART(cv) = CvSTART(proto);
2275 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2278 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2280 SvUTF8_on(MUTABLE_SV(cv));
2283 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2285 if (CvPADLIST(proto))
2286 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2289 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2290 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2291 cv_dump(proto, "Proto");
2299 Perl_cv_clone(pTHX_ CV *proto)
2301 PERL_ARGS_ASSERT_CV_CLONE;
2303 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2304 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2307 /* Called only by pp_clonecv */
2309 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2311 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2313 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2319 Returns an SV containing the name of the CV, mainly for use in error
2320 reporting. The CV may actually be a GV instead, in which case the returned
2321 SV holds the GV's name. Anything other than a GV or CV is treated as a
2322 string already holding the sub name, but this could change in the future.
2324 An SV may be passed as a second argument. If so, the name will be assigned
2325 to it and it will be returned. Otherwise the returned SV will be a new
2328 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2329 included. If the first argument is neither a CV nor a GV, this flag is
2330 ignored (subject to change).
2336 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2338 PERL_ARGS_ASSERT_CV_NAME;
2339 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2340 if (sv) sv_setsv(sv,(SV *)cv);
2341 return sv ? (sv) : (SV *)cv;
2344 SV * const retsv = sv ? (sv) : sv_newmortal();
2345 if (SvTYPE(cv) == SVt_PVCV) {
2347 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2348 sv_sethek(retsv, CvNAME_HEK(cv));
2350 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2351 sv_catpvs(retsv, "::");
2352 sv_cathek(retsv, CvNAME_HEK(cv));
2355 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2356 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2357 else gv_efullname3(retsv, CvGV(cv), NULL);
2359 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2360 else gv_efullname3(retsv,(GV *)cv,NULL);
2366 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2368 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2369 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2370 moved to a pre-existing CV struct.
2376 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2379 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2380 AV * const comppad = PadlistARRAY(padlist)[1];
2381 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2382 SV ** const curpad = AvARRAY(comppad);
2384 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2385 PERL_UNUSED_ARG(old_cv);
2387 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2388 const PADNAME *name = namepad[ix];
2389 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2390 && *PadnamePV(name) == '&')
2392 CV *innercv = MUTABLE_CV(curpad[ix]);
2393 if (UNLIKELY(PadnameOUTER(name))) {
2395 PADNAME **names = namepad;
2397 while (PadnameOUTER(name)) {
2399 names = PadlistNAMESARRAY(CvPADLIST(cv));
2400 i = PARENT_PAD_INDEX(name);
2403 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2405 if (SvTYPE(innercv) == SVt_PVCV) {
2406 /* XXX 0afba48f added code here to check for a proto CV
2407 attached to the pad entry by magic. But shortly there-
2408 after 81df9f6f95 moved the magic to the pad name. The
2409 code here was never updated, so it wasn’t doing anything
2410 and got deleted when PADNAME became a distinct type. Is
2411 there any bug as a result? */
2412 if (CvOUTSIDE(innercv) == old_cv) {
2413 if (!CvWEAKOUTSIDE(innercv)) {
2414 SvREFCNT_dec(old_cv);
2415 SvREFCNT_inc_simple_void_NN(new_cv);
2417 CvOUTSIDE(innercv) = new_cv;
2420 else { /* format reference */
2421 SV * const rv = curpad[ix];
2423 if (!SvOK(rv)) continue;
2425 assert(SvWEAKREF(rv));
2426 innercv = (CV *)SvRV(rv);
2427 assert(!CvWEAKOUTSIDE(innercv));
2428 SvREFCNT_dec(CvOUTSIDE(innercv));
2429 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2436 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2438 Push a new pad frame onto the padlist, unless there's already a pad at
2439 this depth, in which case don't bother creating a new one. Then give
2440 the new pad an @_ in slot zero.
2446 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2448 PERL_ARGS_ASSERT_PAD_PUSH;
2450 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2451 PAD** const svp = PadlistARRAY(padlist);
2452 AV* const newpad = newAV();
2453 SV** const oldpad = AvARRAY(svp[depth-1]);
2454 I32 ix = AvFILLp((const AV *)svp[1]);
2455 const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2456 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2459 for ( ;ix > 0; ix--) {
2460 if (names_fill >= ix && PadnameLEN(names[ix])) {
2461 const char sigil = PadnamePV(names[ix])[0];
2462 if (PadnameOUTER(names[ix])
2463 || PadnameIsSTATE(names[ix])
2466 /* outer lexical or anon code */
2467 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2469 else { /* our own lexical */
2472 sv = MUTABLE_SV(newAV());
2473 else if (sigil == '%')
2474 sv = MUTABLE_SV(newHV());
2477 av_store(newpad, ix, sv);
2480 else if (PadnamePV(names[ix])) {
2481 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2484 /* save temporaries on recursion? */
2485 SV * const sv = newSV(0);
2486 av_store(newpad, ix, sv);
2491 av_store(newpad, 0, MUTABLE_SV(av));
2494 padlist_store(padlist, depth, newpad);
2498 #if defined(USE_ITHREADS)
2500 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2503 =for apidoc padlist_dup
2511 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2517 PERL_ARGS_ASSERT_PADLIST_DUP;
2519 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2520 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2522 max = cloneall ? PadlistMAX(srcpad) : 1;
2524 Newx(dstpad, 1, PADLIST);
2525 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2526 PadlistMAX(dstpad) = max;
2527 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2529 PadlistARRAY(dstpad)[0] = (PAD *)
2530 padnamelist_dup(PadlistNAMES(srcpad), param);
2531 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2534 for (depth = 1; depth <= max; ++depth)
2535 PadlistARRAY(dstpad)[depth] =
2536 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2538 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2539 to build anything other than the first level of pads. */
2540 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2542 const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2543 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2544 SV **oldpad = AvARRAY(srcpad1);
2545 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2551 av_extend(pad1, ix);
2552 PadlistARRAY(dstpad)[1] = pad1;
2553 pad1a = AvARRAY(pad1);
2558 for ( ;ix > 0; ix--) {
2561 } else if (names_fill >= ix && names[ix] &&
2562 PadnameLEN(names[ix])) {
2563 const char sigil = PadnamePV(names[ix])[0];
2564 if (PadnameOUTER(names[ix])
2565 || PadnameIsSTATE(names[ix])
2568 /* outer lexical or anon code */
2569 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2571 else { /* our own lexical */
2572 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2573 /* This is a work around for how the current
2574 implementation of ?{ } blocks in regexps
2575 interacts with lexicals. */
2576 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2581 sv = MUTABLE_SV(newAV());
2582 else if (sigil == '%')
2583 sv = MUTABLE_SV(newHV());
2590 else if (( names_fill >= ix && names[ix]
2591 && PadnamePV(names[ix]) )) {
2592 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2595 /* save temporaries on recursion? */
2596 SV * const sv = newSV(0);
2599 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2600 FIXTHAT before merging this branch.
2601 (And I know how to) */
2602 if (SvPADTMP(oldpad[ix]))
2608 args = newAV(); /* Will be @_ */
2610 pad1a[0] = (SV *)args;
2618 #endif /* USE_ITHREADS */
2621 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2624 SSize_t const oldmax = PadlistMAX(padlist);
2626 PERL_ARGS_ASSERT_PADLIST_STORE;
2630 if (key > PadlistMAX(padlist)) {
2631 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2632 (SV ***)&PadlistARRAY(padlist),
2633 (SV ***)&PadlistARRAY(padlist));
2634 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2637 ary = PadlistARRAY(padlist);
2638 SvREFCNT_dec(ary[key]);
2644 =for apidoc newPADNAMELIST
2646 Creates a new pad name list. C<max> is the highest index for which space
2653 Perl_newPADNAMELIST(size_t max)
2656 Newx(pnl, 1, PADNAMELIST);
2657 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2658 PadnamelistMAX(pnl) = -1;
2659 PadnamelistREFCNT(pnl) = 1;
2660 PadnamelistMAXNAMED(pnl) = 0;
2661 pnl->xpadnl_max = max;
2666 =for apidoc padnamelist_store
2668 Stores the pad name (which may be null) at the given index, freeing any
2669 existing pad name in that slot.
2675 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2679 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2683 if (key > pnl->xpadnl_max)
2684 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2685 (SV ***)&PadnamelistARRAY(pnl),
2686 (SV ***)&PadnamelistARRAY(pnl));
2687 if (PadnamelistMAX(pnl) < key) {
2688 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2689 key-PadnamelistMAX(pnl), PADNAME *);
2690 PadnamelistMAX(pnl) = key;
2692 ary = PadnamelistARRAY(pnl);
2694 PadnameREFCNT_dec(ary[key]);
2700 =for apidoc padnamelist_fetch
2702 Fetches the pad name from the given index.
2708 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2710 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2713 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2717 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2719 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2720 if (!--PadnamelistREFCNT(pnl)) {
2721 while(PadnamelistMAX(pnl) >= 0)
2723 PADNAME * const pn =
2724 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2726 PadnameREFCNT_dec(pn);
2728 Safefree(PadnamelistARRAY(pnl));
2733 #if defined(USE_ITHREADS)
2736 =for apidoc padnamelist_dup
2738 Duplicates a pad name list.
2744 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2746 PADNAMELIST *dstpad;
2747 SSize_t max = PadnamelistMAX(srcpad);
2749 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2751 /* look for it in the table first */
2752 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2756 dstpad = newPADNAMELIST(max);
2757 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2758 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2759 PadnamelistMAX(dstpad) = max;
2761 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2762 for (; max >= 0; max--)
2763 if (PadnamelistARRAY(srcpad)[max]) {
2764 PadnamelistARRAY(dstpad)[max] =
2765 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2766 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2772 #endif /* USE_ITHREADS */
2775 =for apidoc newPADNAMEpvn
2777 Constructs and returns a new pad name. I<s> must be a UTF8 string. Do not
2778 use this for pad names that point to outer lexicals. See
2779 L</newPADNAMEouter>.
2785 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2787 struct padname_with_str *alloc;
2788 char *alloc2; /* for Newxz */
2790 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2792 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2794 alloc = (struct padname_with_str *)alloc2;
2795 pn = (PADNAME *)alloc;
2796 PadnameREFCNT(pn) = 1;
2797 PadnamePV(pn) = alloc->xpadn_str;
2798 Copy(s, PadnamePV(pn), len, char);
2799 *(PadnamePV(pn) + len) = '\0';
2800 PadnameLEN(pn) = len;
2805 =for apidoc newPADNAMEouter
2807 Constructs and returns a new pad name. Only use this function for names
2808 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) I<outer> is
2809 the outer pad name that this one mirrors. The returned pad name has the
2810 PADNAMEt_OUTER flag already set.
2816 Perl_newPADNAMEouter(PADNAME *outer)
2819 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2820 Newxz(pn, 1, PADNAME);
2821 PadnameREFCNT(pn) = 1;
2822 PadnamePV(pn) = PadnamePV(outer);
2823 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2824 another entry. The original pad name owns the buffer. */
2825 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2826 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2827 PadnameLEN(pn) = PadnameLEN(outer);
2832 Perl_padname_free(pTHX_ PADNAME *pn)
2834 PERL_ARGS_ASSERT_PADNAME_FREE;
2835 if (!--PadnameREFCNT(pn)) {
2836 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2837 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2840 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2841 SvREFCNT_dec(PadnameOURSTASH(pn));
2842 if (PadnameOUTER(pn))
2843 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2848 #if defined(USE_ITHREADS)
2851 =for apidoc padname_dup
2853 Duplicates a pad name.
2859 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2863 PERL_ARGS_ASSERT_PADNAME_DUP;
2865 /* look for it in the table first */
2866 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2870 if (!PadnamePV(src)) {
2871 dst = &PL_padname_undef;
2872 ptr_table_store(PL_ptr_table, src, dst);
2876 dst = PadnameOUTER(src)
2877 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2878 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2879 ptr_table_store(PL_ptr_table, src, dst);
2880 PadnameLEN(dst) = PadnameLEN(src);
2881 PadnameFLAGS(dst) = PadnameFLAGS(src);
2882 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2883 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2884 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2886 dst->xpadn_low = src->xpadn_low;
2887 dst->xpadn_high = src->xpadn_high;
2888 dst->xpadn_gen = src->xpadn_gen;
2892 #endif /* USE_ITHREADS */
2896 * c-indentation-style: bsd
2898 * indent-tabs-mode: nil
2901 * ex: set ts=8 sts=4 sw=4 et: