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 C<CvPADLIST>. C<dXSTARG> fetches values from C<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 C<CvPADLIST> if a CV is an XSUB (as
44 determined by C<CvISXSUB()>), C<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 C<@_>. 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 (C<SVs_PADTMP>)
62 and GVs end up having &PL_padname_undef "names", while slots for constants
63 have C<&PL_padname_const> "names" (see C<L</pad_alloc>>). That
65 and C<&PL_padname_const> are used is an implementation detail subject to
66 change. To test for them, use C<!PadnamePV(name)> and
67 S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
69 Only C<my>/C<our> variable slots get valid names.
70 The rest are op targets/GVs/constants which are statically allocated
71 or resolved at compile time. These don't have names by which they
72 can be looked up from Perl code at run time through eval"" the way
73 C<my>/C<our> variables can be. Since they can't be looked up by "name"
74 but only by their index allocated at compile time (which is usually
75 in C<PL_op->op_targ>), wasting a name SV for them doesn't make sense.
77 The pad names in the PADNAMELIST have their PV holding the name of
78 the variable. The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
79 (low+1..high inclusive) of cop_seq numbers for which the name is
80 valid. During compilation, these fields may hold the special value
81 PERL_PADSEQ_INTRO to indicate various stages:
83 COP_SEQ_RANGE_LOW _HIGH
84 ----------------- -----
85 PERL_PADSEQ_INTRO 0 variable not yet introduced:
87 valid-seq# PERL_PADSEQ_INTRO variable in scope:
89 valid-seq# valid-seq# compilation of scope complete:
92 For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
93 lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
94 that duplicate C<our> declarations in the same package can be detected).
95 C<PadnameGEN> is sometimes used to store the generation number during
98 If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
99 is a REFCNT'ed reference to a lexical from "outside". Such entries
100 are sometimes referred to as 'fake'. In this case, the name does not
101 use 'low' and 'high' to store a cop_seq range, since it is in scope
102 throughout. Instead 'high' stores some flags containing info about
103 the real lexical (is it declared in an anon, and is it capable of being
104 instantiated multiple times?), and for fake ANONs, 'low' contains the index
105 within the parent's pad where the lexical's value is stored, to make
108 If the 'name' is C<&> the corresponding entry in the PAD
109 is a CV representing a possible closure.
111 Note that formats are treated as anon subs, and are cloned each time
112 write is called (if necessary).
114 The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
115 and set on scope exit. This allows the
116 C<"Variable $x is not available"> warning
117 to be generated in evals, such as
119 { my $x = 1; sub f { eval '$x'} } f();
121 For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
122 but this internal state is stored in a separate pad entry.
124 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
126 During compilation, this points to the array containing the names part
127 of the pad for the currently-compiling code.
129 =for apidoc AmxU|PAD *|PL_comppad
131 During compilation, this points to the array containing the values
132 part of the pad for the currently-compiling code. (At runtime a CV may
133 have many such value arrays; at compile time just one is constructed.)
134 At runtime, this points to the array containing the currently-relevant
135 values for the pad for the currently-executing code.
137 =for apidoc AmxU|SV **|PL_curpad
139 Points directly to the body of the L</PL_comppad> array.
140 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
147 #define PERL_IN_PAD_C
149 #include "keywords.h"
151 #define COP_SEQ_RANGE_LOW_set(sv,val) \
152 STMT_START { (sv)->xpadn_low = (val); } STMT_END
153 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
154 STMT_START { (sv)->xpadn_high = (val); } STMT_END
156 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
157 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
161 Perl_set_padlist(CV * cv, PADLIST *padlist){
162 PERL_ARGS_ASSERT_SET_PADLIST;
164 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
166 assert((Size_t)padlist != 0xEFEFEFEF);
168 # error unknown pointer size
170 assert(!CvISXSUB(cv));
171 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
176 =for apidoc Am|PADLIST *|pad_new|int flags
178 Create a new padlist, updating the global variables for the
179 currently-compiling padlist to point to the new padlist. The following
180 flags can be OR'ed together:
182 padnew_CLONE this pad is for a cloned CV
183 padnew_SAVE save old globals on the save stack
184 padnew_SAVESUB also save extra stuff for start of sub
190 Perl_pad_new(pTHX_ int flags)
193 PADNAMELIST *padname;
197 ASSERT_CURPAD_LEGAL("pad_new");
199 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
200 * vars (based on flags) rather than storing vals + addresses for
201 * each individually. Also see pad_block_start.
202 * XXX DAPM Try to see whether all these conditionals are required
205 /* save existing state, ... */
207 if (flags & padnew_SAVE) {
209 if (! (flags & padnew_CLONE)) {
210 SAVESPTR(PL_comppad_name);
212 SAVEI32(PL_constpadix);
213 SAVEI32(PL_comppad_name_fill);
214 SAVEI32(PL_min_intro_pending);
215 SAVEI32(PL_max_intro_pending);
216 SAVEBOOL(PL_cv_has_eval);
217 if (flags & padnew_SAVESUB) {
218 SAVEBOOL(PL_pad_reset_pending);
222 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
223 * saved - check at some pt that this is okay */
225 /* ... create new pad ... */
227 Newxz(padlist, 1, PADLIST);
230 if (flags & padnew_CLONE) {
231 /* XXX DAPM I dont know why cv_clone needs it
232 * doing differently yet - perhaps this separate branch can be
233 * dispensed with eventually ???
236 AV * const a0 = newAV(); /* will be @_ */
237 av_store(pad, 0, MUTABLE_SV(a0));
240 PadnamelistREFCNT(padname = PL_comppad_name)++;
243 padlist->xpadl_id = PL_padlist_generation++;
244 av_store(pad, 0, NULL);
245 padname = newPADNAMELIST(0);
246 padnamelist_store(padname, 0, &PL_padname_undef);
249 /* Most subroutines never recurse, hence only need 2 entries in the padlist
250 array - names, and depth=1. The default for av_store() is to allocate
251 0..3, and even an explicit call to av_extend() with <3 will be rounded
252 up, so we inline the allocation of the array here. */
254 PadlistMAX(padlist) = 1;
255 PadlistARRAY(padlist) = ary;
256 ary[0] = (PAD *)padname;
259 /* ... then update state variables */
262 PL_curpad = AvARRAY(pad);
264 if (! (flags & padnew_CLONE)) {
265 PL_comppad_name = padname;
266 PL_comppad_name_fill = 0;
267 PL_min_intro_pending = 0;
273 DEBUG_X(PerlIO_printf(Perl_debug_log,
274 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
275 " name=0x%"UVxf" flags=0x%"UVxf"\n",
276 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
277 PTR2UV(padname), (UV)flags
281 return (PADLIST*)padlist;
286 =head1 Embedding Functions
290 Clear out all the active components of a CV. This can happen either
291 by an explicit C<undef &foo>, or by the reference count going to zero.
292 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
293 children can still follow the full lexical scope chain.
299 Perl_cv_undef(pTHX_ CV *cv)
301 PERL_ARGS_ASSERT_CV_UNDEF;
302 cv_undef_flags(cv, 0);
306 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
308 CV cvbody;/*CV body will never be realloced inside this func,
309 so dont read it more than once, use fake CV so existing macros
310 will work, the indirection and CV head struct optimized away*/
311 SvANY(&cvbody) = SvANY(cv);
313 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
315 DEBUG_X(PerlIO_printf(Perl_debug_log,
316 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
317 PTR2UV(cv), PTR2UV(PL_comppad))
320 if (CvFILE(&cvbody)) {
321 char * file = CvFILE(&cvbody);
322 CvFILE(&cvbody) = NULL;
323 if(CvDYNFILE(&cvbody))
327 /* CvSLABBED_off(&cvbody); *//* turned off below */
328 /* release the sub's body */
329 if (!CvISXSUB(&cvbody)) {
330 if(CvROOT(&cvbody)) {
331 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
332 if (CvDEPTHunsafe(&cvbody)) {
333 assert(SvTYPE(cv) == SVt_PVCV);
334 Perl_croak_nocontext("Can't undef active subroutine");
338 PAD_SAVE_SETNULLPAD();
340 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
341 op_free(CvROOT(&cvbody));
342 CvROOT(&cvbody) = NULL;
343 CvSTART(&cvbody) = NULL;
346 else if (CvSLABBED(&cvbody)) {
347 if( CvSTART(&cvbody)) {
349 PAD_SAVE_SETNULLPAD();
351 /* discard any leaked ops */
353 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
354 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
355 CvSTART(&cvbody) = NULL;
360 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
364 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
365 CvXSUB(&cvbody) = NULL;
367 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
368 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
369 if (!(flags & CV_UNDEF_KEEP_NAME)) {
370 if (CvNAMED(&cvbody)) {
371 CvNAME_HEK_set(&cvbody, NULL);
372 CvNAMED_off(&cvbody);
374 else CvGV_set(cv, NULL);
377 /* This statement and the subsequence if block was pad_undef(). */
378 pad_peg("pad_undef");
380 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
382 const PADLIST *padlist = CvPADLIST(&cvbody);
384 /* Free the padlist associated with a CV.
385 If parts of it happen to be current, we null the relevant PL_*pad*
386 global vars so that we don't have any dangling references left.
387 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
388 subs to the outer of this cv. */
390 DEBUG_X(PerlIO_printf(Perl_debug_log,
391 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
392 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
395 /* detach any '&' anon children in the pad; if afterwards they
396 * are still live, fix up their CvOUTSIDEs to point to our outside,
398 /* XXX DAPM for efficiency, we should only do this if we know we have
399 * children, or integrate this loop with general cleanup */
401 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
402 CV * const outercv = CvOUTSIDE(&cvbody);
403 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
404 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
405 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
406 PAD * const comppad = PadlistARRAY(padlist)[1];
407 SV ** const curpad = AvARRAY(comppad);
408 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
409 PADNAME * const name = namepad[ix];
410 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
412 CV * const innercv = MUTABLE_CV(curpad[ix]);
413 U32 inner_rc = SvREFCNT(innercv);
415 assert(SvTYPE(innercv) != SVt_PVFM);
417 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
419 SvREFCNT_dec_NN(innercv);
423 /* in use, not just a prototype */
424 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
425 && (CvOUTSIDE(innercv) == cv))
427 assert(CvWEAKOUTSIDE(innercv));
428 /* don't relink to grandfather if he's being freed */
429 if (outercv && SvREFCNT(outercv)) {
430 CvWEAKOUTSIDE_off(innercv);
431 CvOUTSIDE(innercv) = outercv;
432 CvOUTSIDE_SEQ(innercv) = seq;
433 SvREFCNT_inc_simple_void_NN(outercv);
436 CvOUTSIDE(innercv) = NULL;
443 ix = PadlistMAX(padlist);
445 PAD * const sv = PadlistARRAY(padlist)[ix--];
447 if (sv == PL_comppad) {
455 PADNAMELIST * const names = PadlistNAMES(padlist);
456 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
457 PL_comppad_name = NULL;
458 PadnamelistREFCNT_dec(names);
460 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
462 CvPADLIST_set(&cvbody, NULL);
464 else if (CvISXSUB(&cvbody))
465 CvHSCXT(&cvbody) = NULL;
466 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
469 /* remove CvOUTSIDE unless this is an undef rather than a free */
471 CV * outside = CvOUTSIDE(&cvbody);
473 CvOUTSIDE(&cvbody) = NULL;
474 if (!CvWEAKOUTSIDE(&cvbody))
475 SvREFCNT_dec_NN(outside);
478 if (CvCONST(&cvbody)) {
479 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
480 /* CvCONST_off(cv); *//* turned off below */
482 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
483 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
484 * LEXICAL, which are used to determine the sub's name. */
485 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
490 =for apidoc cv_forget_slab
492 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
493 for making sure it is freed. (Hence, no two CVs should ever have a
494 reference count on the same slab.) The CV only needs to reference the slab
495 during compilation. Once it is compiled and C<CvROOT> attached, it has
496 finished its job, so it can forget the slab.
502 Perl_cv_forget_slab(pTHX_ CV *cv)
509 slabbed = cBOOL(CvSLABBED(cv));
510 if (!slabbed) return;
514 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
515 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
517 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
521 #ifdef PERL_DEBUG_READONLY_OPS
522 const size_t refcnt = slab->opslab_refcnt;
524 OpslabREFCNT_dec(slab);
525 #ifdef PERL_DEBUG_READONLY_OPS
526 if (refcnt > 1) Slab_to_ro(slab);
532 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
534 Allocates a place in the currently-compiling
535 pad (via L<perlapi/pad_alloc>) and
536 then stores a name for that entry. C<name> is adopted and
537 becomes the name entry; it must already contain the name
538 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
539 flag get added to C<name>. None of the other
540 processing of L<perlapi/pad_add_name_pvn>
541 is done. Returns the offset of the allocated pad slot.
547 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
550 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
552 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
554 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
557 SvPAD_TYPED_on(name);
559 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
563 SvOURSTASH_set(name, ourstash);
564 SvREFCNT_inc_simple_void_NN(ourstash);
566 else if (flags & padadd_STATE) {
567 SvPAD_STATE_on(name);
570 padnamelist_store(PL_comppad_name, offset, name);
571 if (PadnameLEN(name) > 1)
572 PadnamelistMAXNAMED(PL_comppad_name) = offset;
577 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
579 Allocates a place in the currently-compiling pad for a named lexical
580 variable. Stores the name and other metadata in the name part of the
581 pad, and makes preparations to manage the variable's lexical scoping.
582 Returns the offset of the allocated pad slot.
584 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
585 If C<typestash> is non-null, the name is for a typed lexical, and this
586 identifies the type. If C<ourstash> is non-null, it's a lexical reference
587 to a package variable, and this identifies the package. The following
588 flags can be OR'ed together:
590 padadd_OUR redundantly specifies if it's a package var
591 padadd_STATE variable will retain value persistently
592 padadd_NO_DUP_CHECK skip check for lexical shadowing
598 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
599 U32 flags, HV *typestash, HV *ourstash)
604 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
606 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
607 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
610 name = newPADNAMEpvn(namepv, namelen);
612 if ((flags & padadd_NO_DUP_CHECK) == 0) {
614 SAVEFREEPADNAME(name); /* in case of fatal warnings */
615 /* check for duplicate declaration */
616 pad_check_dup(name, flags & padadd_OUR, ourstash);
617 PadnameREFCNT(name)++;
621 offset = pad_alloc_name(name, flags, typestash, ourstash);
623 /* not yet introduced */
624 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
625 COP_SEQ_RANGE_HIGH_set(name, 0);
627 if (!PL_min_intro_pending)
628 PL_min_intro_pending = offset;
629 PL_max_intro_pending = offset;
630 /* if it's not a simple scalar, replace with an AV or HV */
631 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
632 assert(SvREFCNT(PL_curpad[offset]) == 1);
633 if (namelen != 0 && *namepv == '@')
634 sv_upgrade(PL_curpad[offset], SVt_PVAV);
635 else if (namelen != 0 && *namepv == '%')
636 sv_upgrade(PL_curpad[offset], SVt_PVHV);
637 else if (namelen != 0 && *namepv == '&')
638 sv_upgrade(PL_curpad[offset], SVt_PVCV);
639 assert(SvPADMY(PL_curpad[offset]));
640 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
641 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
642 (long)offset, PadnamePV(name),
643 PTR2UV(PL_curpad[offset])));
649 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
651 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
652 instead of a string/length pair.
658 Perl_pad_add_name_pv(pTHX_ const char *name,
659 const U32 flags, HV *typestash, HV *ourstash)
661 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
662 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
666 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
668 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
669 of an SV instead of a string/length pair.
675 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
679 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
680 namepv = SvPVutf8(name, namelen);
681 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
685 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
687 Allocates a place in the currently-compiling pad,
688 returning the offset of the allocated pad slot.
689 No name is initially attached to the pad slot.
690 C<tmptype> is a set of flags indicating the kind of pad entry required,
691 which will be set in the value SV for the allocated pad entry:
693 SVs_PADMY named lexical variable ("my", "our", "state")
694 SVs_PADTMP unnamed temporary store
695 SVf_READONLY constant shared between recursion levels
697 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
698 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
699 does not cause the SV in the pad slot to be marked read-only, but simply
700 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
701 least should be treated as such.
703 C<optype> should be an opcode indicating the type of operation that the
704 pad entry is to support. This doesn't affect operational semantics,
705 but is used for debugging.
710 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
711 * or at least rationalise ??? */
714 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
719 PERL_UNUSED_ARG(optype);
720 ASSERT_CURPAD_ACTIVE("pad_alloc");
722 if (AvARRAY(PL_comppad) != PL_curpad)
723 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
724 AvARRAY(PL_comppad), PL_curpad);
725 if (PL_pad_reset_pending)
727 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
728 /* For a my, simply push a null SV onto the end of PL_comppad. */
729 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
730 retval = AvFILLp(PL_comppad);
733 /* For a tmp, scan the pad from PL_padix upwards
734 * for a slot which has no name and no active value.
735 * For a constant, likewise, but use PL_constpadix.
737 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
738 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
739 const bool konst = cBOOL(tmptype & SVf_READONLY);
740 retval = konst ? PL_constpadix : PL_padix;
743 * Entries that close over unavailable variables
744 * in outer subs contain values not marked PADMY.
745 * Thus we must skip, not just pad values that are
746 * marked as current pad values, but also those with names.
747 * If pad_reset is enabled, ‘current’ means different
748 * things depending on whether we are allocating a con-
749 * stant or a target. For a target, things marked PADTMP
750 * can be reused; not so for constants.
753 if (++retval <= names_fill &&
754 (pn = names[retval]) && PadnamePV(pn))
756 sv = *av_fetch(PL_comppad, retval, TRUE);
759 (konst ? SVs_PADTMP : 0))
767 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
768 tmptype &= ~SVf_READONLY;
769 tmptype |= SVs_PADTMP;
771 *(konst ? &PL_constpadix : &PL_padix) = retval;
773 SvFLAGS(sv) |= tmptype;
774 PL_curpad = AvARRAY(PL_comppad);
776 DEBUG_X(PerlIO_printf(Perl_debug_log,
777 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
778 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
779 PL_op_name[optype]));
780 #ifdef DEBUG_LEAKING_SCALARS
781 sv->sv_debug_optype = optype;
782 sv->sv_debug_inpad = 1;
784 return (PADOFFSET)retval;
788 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
790 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
791 for an anonymous function that is lexically scoped inside the
792 currently-compiling function.
793 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
794 to the outer scope is weakened to avoid a reference loop.
796 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
798 C<optype> should be an opcode indicating the type of operation that the
799 pad entry is to support. This doesn't affect operational semantics,
800 but is used for debugging.
806 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
809 PADNAME * const name = newPADNAMEpvn("&", 1);
811 PERL_ARGS_ASSERT_PAD_ADD_ANON;
812 assert (SvTYPE(func) == SVt_PVCV);
815 /* These two aren't used; just make sure they're not equal to
816 * PERL_PADSEQ_INTRO. They should be 0 by default. */
817 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
818 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
819 ix = pad_alloc(optype, SVs_PADMY);
820 padnamelist_store(PL_comppad_name, ix, name);
821 /* XXX DAPM use PL_curpad[] ? */
822 av_store(PL_comppad, ix, (SV*)func);
824 /* to avoid ref loops, we never have parent + child referencing each
825 * other simultaneously */
826 if (CvOUTSIDE(func)) {
827 assert(!CvWEAKOUTSIDE(func));
828 CvWEAKOUTSIDE_on(func);
829 SvREFCNT_dec_NN(CvOUTSIDE(func));
835 Perl_pad_add_weakref(pTHX_ CV* func)
837 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
838 PADNAME * const name = newPADNAMEpvn("&", 1);
839 SV * const rv = newRV_inc((SV *)func);
841 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
843 /* These two aren't used; just make sure they're not equal to
844 * PERL_PADSEQ_INTRO. They should be 0 by default. */
845 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
846 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
847 padnamelist_store(PL_comppad_name, ix, name);
849 av_store(PL_comppad, ix, rv);
853 =for apidoc pad_check_dup
855 Check for duplicate declarations: report any of:
857 * a 'my' in the current scope with the same name;
858 * an 'our' (anywhere in the pad) with the same name and the
859 same stash as 'ourstash'
861 C<is_our> indicates that the name to check is an C<"our"> declaration.
867 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
871 const U32 is_our = flags & padadd_OUR;
873 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
875 ASSERT_CURPAD_ACTIVE("pad_check_dup");
877 assert((flags & ~padadd_OUR) == 0);
879 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
880 return; /* nothing to check */
882 svp = PadnamelistARRAY(PL_comppad_name);
883 top = PadnamelistMAX(PL_comppad_name);
884 /* check the current scope */
885 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
887 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
888 PADNAME * const sv = svp[off];
890 && PadnameLEN(sv) == PadnameLEN(name)
892 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
893 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
894 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
896 if (is_our && (SvPAD_OUR(sv)))
897 break; /* "our" masking "our" */
898 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
899 Perl_warner(aTHX_ packWARN(WARN_MISC),
900 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
902 PL_parser->in_my == KEY_my ? "my" :
903 PL_parser->in_my == KEY_sigvar ? "my" :
905 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
907 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
908 ? "scope" : "statement"));
913 /* check the rest of the pad */
916 PADNAME * const sv = svp[off];
918 && PadnameLEN(sv) == PadnameLEN(name)
920 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
921 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
922 && SvOURSTASH(sv) == ourstash
923 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
925 Perl_warner(aTHX_ packWARN(WARN_MISC),
926 "\"our\" variable %"PNf" redeclared", PNfARG(sv));
927 if ((I32)off <= PL_comppad_name_floor)
928 Perl_warner(aTHX_ packWARN(WARN_MISC),
929 "\t(Did you mean \"local\" instead of \"our\"?)\n");
939 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
941 Given the name of a lexical variable, find its position in the
942 currently-compiling pad.
943 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
944 C<flags> is reserved and must be zero.
945 If it is not in the current pad but appears in the pad of any lexically
946 enclosing scope, then a pseudo-entry for it is added in the current pad.
947 Returns the offset in the current pad,
948 or C<NOT_IN_PAD> if no such lexical is in scope.
954 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
959 const PADNAMELIST *namelist;
962 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
964 pad_peg("pad_findmy_pvn");
967 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
970 /* compilation errors can zero PL_compcv */
974 offset = pad_findlex(namepv, namelen, flags,
975 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
976 if ((PADOFFSET)offset != NOT_IN_PAD)
979 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
981 if (*namepv == '&') return NOT_IN_PAD;
983 /* look for an our that's being introduced; this allows
984 * our $foo = 0 unless defined $foo;
985 * to not give a warning. (Yes, this is a hack) */
987 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
988 name_p = PadnamelistARRAY(namelist);
989 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
990 const PADNAME * const name = name_p[offset];
991 if (name && PadnameLEN(name) == namelen
992 && !PadnameOUTER(name)
993 && (PadnameIsOUR(name))
994 && ( PadnamePV(name) == namepv
995 || memEQ(PadnamePV(name), namepv, namelen) )
996 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
1004 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1006 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1007 instead of a string/length pair.
1013 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1015 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1016 return pad_findmy_pvn(name, strlen(name), flags);
1020 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1022 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1023 of an SV instead of a string/length pair.
1029 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1033 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1034 namepv = SvPVutf8(name, namelen);
1035 return pad_findmy_pvn(namepv, namelen, flags);
1039 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1041 Until the lexical C<$_> feature was removed, this function would
1042 find the position of the lexical C<$_> in the pad of the
1043 currently-executing function and returns the offset in the current pad,
1046 Now it always returns C<NOT_IN_PAD>.
1052 Perl_find_rundefsvoffset(pTHX)
1054 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1059 =for apidoc Am|SV *|find_rundefsv
1061 Returns the global variable C<$_>.
1067 Perl_find_rundefsv(pTHX)
1073 =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
1075 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1076 in the inner pads if it's found in an outer one.
1078 Returns the offset in the bottom pad of the lex or the fake lex.
1079 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1080 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1081 vars return values, and so are pointers to where the returned values
1082 should be stored. C<out_capture>, if non-null, requests that the innermost
1083 instance of the lexical is captured; C<out_name> is set to the innermost
1084 matched pad name or fake pad name; C<out_flags> returns the flags normally
1085 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1087 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1088 then comes back down, adding fake entries
1089 as it goes. It has to be this way
1090 because fake names in anon protoypes have to store in C<xlow> the index into
1096 /* the CV has finished being compiled. This is not a sufficient test for
1097 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1098 #define CvCOMPILED(cv) CvROOT(cv)
1100 /* the CV does late binding of its lexicals */
1101 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1104 S_unavailable(pTHX_ PADNAME *name)
1106 /* diag_listed_as: Variable "%s" is not available */
1107 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1108 "%se \"%"PNf"\" is not available",
1109 *PadnamePV(name) == '&'
1116 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1117 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1119 I32 offset, new_offset;
1122 const PADLIST * const padlist = CvPADLIST(cv);
1123 const bool staleok = !!(flags & padadd_STALEOK);
1125 PERL_ARGS_ASSERT_PAD_FINDLEX;
1127 flags &= ~ padadd_STALEOK; /* one-shot flag */
1129 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1134 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1135 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1136 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1137 out_capture ? " capturing" : "" ));
1139 /* first, search this pad */
1141 if (padlist) { /* not an undef CV */
1142 I32 fake_offset = 0;
1143 const PADNAMELIST * const names = PadlistNAMES(padlist);
1144 PADNAME * const * const name_p = PadnamelistARRAY(names);
1146 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1147 const PADNAME * const name = name_p[offset];
1148 if (name && PadnameLEN(name) == namelen
1149 && ( PadnamePV(name) == namepv
1150 || memEQ(PadnamePV(name), namepv, namelen) ))
1152 if (PadnameOUTER(name)) {
1153 fake_offset = offset; /* in case we don't find a real one */
1156 if (PadnameIN_SCOPE(name, seq))
1161 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1162 if (offset > 0) { /* not fake */
1164 *out_name = name_p[offset]; /* return the name */
1166 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1167 * instances. For now, we just test !CvUNIQUE(cv), but
1168 * ideally, we should detect my's declared within loops
1169 * etc - this would allow a wider range of 'not stayed
1170 * shared' warnings. We also treated already-compiled
1171 * lexes as not multi as viewed from evals. */
1173 *out_flags = CvANON(cv) ?
1175 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1176 ? PAD_FAKELEX_MULTI : 0;
1178 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1179 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1180 PTR2UV(cv), (long)offset,
1181 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1182 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1184 else { /* fake match */
1185 offset = fake_offset;
1186 *out_name = name_p[offset]; /* return the name */
1187 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1188 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1189 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1190 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1191 (unsigned long) PARENT_PAD_INDEX(*out_name)
1195 /* return the lex? */
1200 if (PadnameIsOUR(*out_name)) {
1201 *out_capture = NULL;
1205 /* trying to capture from an anon prototype? */
1207 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1208 : *out_flags & PAD_FAKELEX_ANON)
1214 *out_capture = NULL;
1220 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1221 && !PadnameIsSTATE(name_p[offset])
1222 && warn && ckWARN(WARN_CLOSURE)) {
1224 /* diag_listed_as: Variable "%s" will not stay
1226 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1227 "%se \"%"UTF8f"\" will not stay shared",
1228 *namepv == '&' ? "Subroutin" : "Variabl",
1229 UTF8fARG(1, namelen, namepv));
1232 if (fake_offset && CvANON(cv)
1233 && CvCLONE(cv) &&!CvCLONED(cv))
1236 /* not yet caught - look further up */
1237 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1238 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1241 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1243 newwarn, out_capture, out_name, out_flags);
1248 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1249 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1250 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1251 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1252 PTR2UV(cv), PTR2UV(*out_capture)));
1254 if (SvPADSTALE(*out_capture)
1255 && (!CvDEPTH(cv) || !staleok)
1256 && !PadnameIsSTATE(name_p[offset]))
1260 *out_capture = NULL;
1263 if (!*out_capture) {
1264 if (namelen != 0 && *namepv == '@')
1265 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1266 else if (namelen != 0 && *namepv == '%')
1267 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1268 else if (namelen != 0 && *namepv == '&')
1269 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1271 *out_capture = sv_newmortal();
1279 /* it's not in this pad - try above */
1284 /* out_capture non-null means caller wants us to capture lex; in
1285 * addition we capture ourselves unless it's an ANON/format */
1286 new_capturep = out_capture ? out_capture :
1287 CvLATE(cv) ? NULL : &new_capture;
1289 offset = pad_findlex(namepv, namelen,
1290 flags | padadd_STALEOK*(new_capturep == &new_capture),
1291 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1292 new_capturep, out_name, out_flags);
1293 if ((PADOFFSET)offset == NOT_IN_PAD)
1296 /* found in an outer CV. Add appropriate fake entry to this pad */
1298 /* don't add new fake entries (via eval) to CVs that we have already
1299 * finished compiling, or to undef CVs */
1300 if (CvCOMPILED(cv) || !padlist)
1301 return 0; /* this dummy (and invalid) value isnt used by the caller */
1304 PADNAME *new_name = newPADNAMEouter(*out_name);
1305 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1306 PAD * const ocomppad = PL_comppad;
1307 PL_comppad_name = PadlistNAMES(padlist);
1308 PL_comppad = PadlistARRAY(padlist)[1];
1309 PL_curpad = AvARRAY(PL_comppad);
1312 = pad_alloc_name(new_name,
1313 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1314 PadnameTYPE(*out_name),
1315 PadnameOURSTASH(*out_name)
1318 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1319 "Pad addname: %ld \"%.*s\" FAKE\n",
1321 (int) PadnameLEN(new_name),
1322 PadnamePV(new_name)));
1323 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1325 PARENT_PAD_INDEX_set(new_name, 0);
1326 if (PadnameIsOUR(new_name)) {
1327 NOOP; /* do nothing */
1329 else if (CvLATE(cv)) {
1330 /* delayed creation - just note the offset within parent pad */
1331 PARENT_PAD_INDEX_set(new_name, offset);
1335 /* immediate creation - capture outer value right now */
1336 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1337 /* But also note the offset, as newMYSUB needs it */
1338 PARENT_PAD_INDEX_set(new_name, offset);
1339 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1340 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1341 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1343 *out_name = new_name;
1344 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1346 PL_comppad_name = ocomppad_name;
1347 PL_comppad = ocomppad;
1348 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1356 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1358 Get the value at offset C<po> in the current (compiling or executing) pad.
1359 Use macro C<PAD_SV> instead of calling this function directly.
1365 Perl_pad_sv(pTHX_ PADOFFSET po)
1367 ASSERT_CURPAD_ACTIVE("pad_sv");
1370 Perl_croak(aTHX_ "panic: pad_sv po");
1371 DEBUG_X(PerlIO_printf(Perl_debug_log,
1372 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1373 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1375 return PL_curpad[po];
1379 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1381 Set the value at offset C<po> in the current (compiling or executing) pad.
1382 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1388 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1390 PERL_ARGS_ASSERT_PAD_SETSV;
1392 ASSERT_CURPAD_ACTIVE("pad_setsv");
1394 DEBUG_X(PerlIO_printf(Perl_debug_log,
1395 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1396 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1401 #endif /* DEBUGGING */
1404 =for apidoc m|void|pad_block_start|int full
1406 Update the pad compilation state variables on entry to a new block.
1411 /* XXX DAPM perhaps:
1412 * - integrate this in general state-saving routine ???
1413 * - combine with the state-saving going on in pad_new ???
1414 * - introduce a new SAVE type that does all this in one go ?
1418 Perl_pad_block_start(pTHX_ int full)
1420 ASSERT_CURPAD_ACTIVE("pad_block_start");
1421 SAVEI32(PL_comppad_name_floor);
1422 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1424 PL_comppad_name_fill = PL_comppad_name_floor;
1425 if (PL_comppad_name_floor < 0)
1426 PL_comppad_name_floor = 0;
1427 SAVEI32(PL_min_intro_pending);
1428 SAVEI32(PL_max_intro_pending);
1429 PL_min_intro_pending = 0;
1430 SAVEI32(PL_comppad_name_fill);
1431 SAVEI32(PL_padix_floor);
1432 /* PL_padix_floor is what PL_padix is reset to at the start of each
1433 statement, by pad_reset(). We set it when entering a new scope
1434 to keep things like this working:
1435 print "$foo$bar", do { this(); that() . "foo" };
1436 We must not let "$foo$bar" and the later concatenation share the
1438 PL_padix_floor = PL_padix;
1439 PL_pad_reset_pending = FALSE;
1443 =for apidoc Am|U32|intro_my
1445 "Introduce" C<my> variables to visible status. This is called during parsing
1446 at the end of each statement to make lexical variables visible to subsequent
1459 ASSERT_CURPAD_ACTIVE("intro_my");
1460 if (PL_compiling.cop_seq) {
1461 seq = PL_compiling.cop_seq;
1462 PL_compiling.cop_seq = 0;
1465 seq = PL_cop_seqmax;
1466 if (! PL_min_intro_pending)
1469 svp = PadnamelistARRAY(PL_comppad_name);
1470 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1471 PADNAME * const sv = svp[i];
1473 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1474 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1476 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1477 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1478 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1479 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1480 (long)i, PadnamePV(sv),
1481 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1482 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1487 PL_min_intro_pending = 0;
1488 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1489 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1490 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1496 =for apidoc m|void|pad_leavemy
1498 Cleanup at end of scope during compilation: set the max seq number for
1499 lexicals in this scope and warn of any lexicals that never got introduced.
1505 Perl_pad_leavemy(pTHX)
1509 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1511 PL_pad_reset_pending = FALSE;
1513 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1514 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1515 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1516 const PADNAME * const name = svp[off];
1517 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1518 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1519 "%"PNf" never introduced",
1523 /* "Deintroduce" my variables that are leaving with this scope. */
1524 for (off = PadnamelistMAX(PL_comppad_name);
1525 off > PL_comppad_name_fill; off--) {
1526 PADNAME * const sv = svp[off];
1527 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1528 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1530 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1531 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1532 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1533 (long)off, PadnamePV(sv),
1534 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1535 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1537 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1538 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1539 OP *kid = newOP(OP_INTROCV, 0);
1541 o = op_prepend_elem(OP_LINESEQ, kid, o);
1546 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1547 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1552 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1554 Abandon the tmp in the current pad at offset C<po> and replace with a
1561 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1563 ASSERT_CURPAD_LEGAL("pad_swipe");
1566 if (AvARRAY(PL_comppad) != PL_curpad)
1567 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1568 AvARRAY(PL_comppad), PL_curpad);
1569 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1570 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1571 (long)po, (long)AvFILLp(PL_comppad));
1573 DEBUG_X(PerlIO_printf(Perl_debug_log,
1574 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1575 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1578 SvREFCNT_dec(PL_curpad[po]);
1581 /* if pad tmps aren't shared between ops, then there's no need to
1582 * create a new tmp when an existing op is freed */
1583 #ifdef USE_PAD_RESET
1584 PL_curpad[po] = newSV(0);
1585 SvPADTMP_on(PL_curpad[po]);
1587 PL_curpad[po] = NULL;
1589 if (PadnamelistMAX(PL_comppad_name) != -1
1590 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1591 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1592 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1594 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1596 /* Use PL_constpadix here, not PL_padix. The latter may have been
1597 reset by pad_reset. We don’t want pad_alloc to have to scan the
1598 whole pad when allocating a constant. */
1599 if ((I32)po < PL_constpadix)
1600 PL_constpadix = po - 1;
1604 =for apidoc m|void|pad_reset
1606 Mark all the current temporaries for reuse
1611 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1612 * between OPs from different statements. During compilation, at the start
1613 * of each statement pad_reset resets PL_padix back to its previous value.
1614 * When allocating a target, pad_alloc begins its scan through the pad at
1619 #ifdef USE_PAD_RESET
1620 if (AvARRAY(PL_comppad) != PL_curpad)
1621 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1622 AvARRAY(PL_comppad), PL_curpad);
1624 DEBUG_X(PerlIO_printf(Perl_debug_log,
1625 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1626 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1627 (long)PL_padix, (long)PL_padix_floor
1631 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1632 PL_padix = PL_padix_floor;
1635 PL_pad_reset_pending = FALSE;
1639 =for apidoc Amx|void|pad_tidy|padtidy_type type
1641 Tidy up a pad at the end of compilation of the code to which it belongs.
1642 Jobs performed here are: remove most stuff from the pads of anonsub
1643 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1644 the kind of subroutine:
1646 padtidy_SUB ordinary subroutine
1647 padtidy_SUBCLONE prototype for lexical closure
1648 padtidy_FORMAT format
1653 /* XXX DAPM surely most of this stuff should be done properly
1654 * at the right time beforehand, rather than going around afterwards
1655 * cleaning up our mistakes ???
1659 Perl_pad_tidy(pTHX_ padtidy_type type)
1663 ASSERT_CURPAD_ACTIVE("pad_tidy");
1665 /* If this CV has had any 'eval-capable' ops planted in it:
1666 * i.e. it contains any of:
1670 * * use re 'eval'; /$var/
1673 * Then any anon prototypes in the chain of CVs should be marked as
1674 * cloneable, so that for example the eval's CV in
1678 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1679 * potentially have an eval executed within it.
1682 if (PL_cv_has_eval || PL_perldb) {
1684 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1685 if (cv != PL_compcv && CvCOMPILED(cv))
1686 break; /* no need to mark already-compiled code */
1688 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1689 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1696 /* extend namepad to match curpad */
1697 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1698 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1700 if (type == padtidy_SUBCLONE) {
1701 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1704 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1706 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1709 * The only things that a clonable function needs in its
1710 * pad are anonymous subs, constants and GVs.
1711 * The rest are created anew during cloning.
1713 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1716 if (!(PadnamePV(namesv) &&
1717 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1719 SvREFCNT_dec(PL_curpad[ix]);
1720 PL_curpad[ix] = NULL;
1724 else if (type == padtidy_SUB) {
1725 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1726 AV * const av = newAV(); /* Will be @_ */
1727 av_store(PL_comppad, 0, MUTABLE_SV(av));
1731 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1732 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1734 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1735 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1736 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1738 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1739 /* This is a work around for how the current implementation of
1740 ?{ } blocks in regexps interacts with lexicals.
1742 One of our lexicals.
1743 Can't do this on all lexicals, otherwise sub baz() won't
1752 because completion of compiling &bar calling pad_tidy()
1753 would cause (top level) $foo to be marked as stale, and
1754 "no longer available". */
1755 SvPADSTALE_on(PL_curpad[ix]);
1759 PL_curpad = AvARRAY(PL_comppad);
1763 =for apidoc m|void|pad_free|PADOFFSET po
1765 Free the SV at offset po in the current pad.
1770 /* XXX DAPM integrate with pad_swipe ???? */
1772 Perl_pad_free(pTHX_ PADOFFSET po)
1774 #ifndef USE_PAD_RESET
1777 ASSERT_CURPAD_LEGAL("pad_free");
1780 if (AvARRAY(PL_comppad) != PL_curpad)
1781 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1782 AvARRAY(PL_comppad), PL_curpad);
1784 Perl_croak(aTHX_ "panic: pad_free po");
1786 DEBUG_X(PerlIO_printf(Perl_debug_log,
1787 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1788 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1791 #ifndef USE_PAD_RESET
1793 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1794 SvFLAGS(sv) &= ~SVs_PADTMP;
1796 if ((I32)po < PL_padix)
1802 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1804 Dump the contents of a padlist
1810 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1812 const PADNAMELIST *pad_name;
1818 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1823 pad_name = PadlistNAMES(padlist);
1824 pad = PadlistARRAY(padlist)[1];
1825 pname = PadnamelistARRAY(pad_name);
1826 ppad = AvARRAY(pad);
1827 Perl_dump_indent(aTHX_ level, file,
1828 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1829 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1832 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1833 const PADNAME *namesv = pname[ix];
1834 if (namesv && !PadnameLEN(namesv)) {
1838 if (PadnameOUTER(namesv))
1839 Perl_dump_indent(aTHX_ level+1, file,
1840 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1843 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1845 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1846 (unsigned long)PARENT_PAD_INDEX(namesv)
1850 Perl_dump_indent(aTHX_ level+1, file,
1851 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1854 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1855 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1856 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1861 Perl_dump_indent(aTHX_ level+1, file,
1862 "%2d. 0x%"UVxf"<%lu>\n",
1865 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1874 =for apidoc m|void|cv_dump|CV *cv|const char *title
1876 dump the contents of a CV
1882 S_cv_dump(pTHX_ const CV *cv, const char *title)
1884 const CV * const outside = CvOUTSIDE(cv);
1885 PADLIST* const padlist = CvPADLIST(cv);
1887 PERL_ARGS_ASSERT_CV_DUMP;
1889 PerlIO_printf(Perl_debug_log,
1890 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1893 (CvANON(cv) ? "ANON"
1894 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1895 : (cv == PL_main_cv) ? "MAIN"
1896 : CvUNIQUE(cv) ? "UNIQUE"
1897 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1900 : CvANON(outside) ? "ANON"
1901 : (outside == PL_main_cv) ? "MAIN"
1902 : CvUNIQUE(outside) ? "UNIQUE"
1903 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1905 PerlIO_printf(Perl_debug_log,
1906 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1907 do_dump_pad(1, Perl_debug_log, padlist, 1);
1910 #endif /* DEBUGGING */
1913 =for apidoc Am|CV *|cv_clone|CV *proto
1915 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1916 of the function: its code, pad structure, and other attributes.
1917 The prototype is combined with a capture of outer lexicals to which the
1918 code refers, which are taken from the currently-executing instance of
1919 the immediately surrounding code.
1924 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1927 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1931 PADLIST* const protopadlist = CvPADLIST(proto);
1932 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1933 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1934 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1935 SV** const ppad = AvARRAY(protopad);
1936 const I32 fname = PadnamelistMAX(protopad_name);
1937 const I32 fpad = AvFILLp(protopad);
1941 bool trouble = FALSE;
1943 assert(!CvUNIQUE(proto));
1945 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1946 * reliable. The currently-running sub is always the one we need to
1948 * For my subs, the currently-running sub may not be the one we want.
1949 * We have to check whether it is a clone of CvOUTSIDE.
1950 * Note that in general for formats, CvOUTSIDE != find_runcv.
1951 * Since formats may be nested inside closures, CvOUTSIDE may point
1952 * to a prototype; we instead want the cloned parent who called us.
1956 if (CvWEAKOUTSIDE(proto))
1957 outside = find_runcv(NULL);
1959 outside = CvOUTSIDE(proto);
1960 if ((CvCLONE(outside) && ! CvCLONED(outside))
1961 || !CvPADLIST(outside)
1962 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1963 outside = find_runcv_where(
1964 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1966 /* outside could be null */
1970 depth = outside ? CvDEPTH(outside) : 0;
1975 SAVESPTR(PL_compcv);
1977 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1980 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1982 SAVESPTR(PL_comppad_name);
1983 PL_comppad_name = protopad_name;
1984 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1985 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1987 av_fill(PL_comppad, fpad);
1989 PL_curpad = AvARRAY(PL_comppad);
1991 outpad = outside && CvPADLIST(outside)
1992 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1994 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1996 for (ix = fpad; ix > 0; ix--) {
1997 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1999 if (namesv && PadnameLEN(namesv)) { /* lexical */
2000 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2004 if (PadnameOUTER(namesv)) { /* lexical from outside? */
2005 /* formats may have an inactive, or even undefined, parent;
2006 but state vars are always available. */
2007 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2008 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2009 && (!outside || !CvDEPTH(outside))) ) {
2010 S_unavailable(aTHX_ namesv);
2014 SvREFCNT_inc_simple_void_NN(sv);
2017 const char sigil = PadnamePV(namesv)[0];
2019 /* If there are state subs, we need to clone them, too.
2020 But they may need to close over variables we have
2021 not cloned yet. So we will have to do a second
2022 pass. Furthermore, there may be state subs clos-
2023 ing over other state subs’ entries, so we have
2024 to put a stub here and then clone into it on the
2026 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2027 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2029 if (CvOUTSIDE(ppad[ix]) != proto)
2031 sv = newSV_type(SVt_PVCV);
2034 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2037 /* Just provide a stub, but name it. It will be
2038 upgrade to the real thing on scope entry. */
2041 PERL_HASH(hash, PadnamePV(namesv)+1,
2042 PadnameLEN(namesv) - 1);
2043 sv = newSV_type(SVt_PVCV);
2046 share_hek(PadnamePV(namesv)+1,
2047 1 - PadnameLEN(namesv),
2052 else sv = SvREFCNT_inc(ppad[ix]);
2053 else if (sigil == '@')
2054 sv = MUTABLE_SV(newAV());
2055 else if (sigil == '%')
2056 sv = MUTABLE_SV(newHV());
2059 /* reset the 'assign only once' flag on each state var */
2060 if (sigil != '&' && SvPAD_STATE(namesv))
2065 else if (namesv && PadnamePV(namesv)) {
2066 sv = SvREFCNT_inc_NN(ppad[ix]);
2077 if (trouble || cloned) {
2078 /* Uh-oh, we have trouble! At least one of the state subs here
2079 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2080 could be pointing to another state protosub that we are
2081 about to clone. So we have to track which sub clones come
2082 from which protosubs. If the CvOUTSIDE pointer for a parti-
2083 cular sub points to something we have not cloned yet, we
2084 delay cloning it. We must loop through the pad entries,
2085 until we get a full pass with no cloning. If any uncloned
2086 subs remain (probably nested inside anonymous or ‘my’ subs),
2087 then they get cloned in a final pass.
2089 bool cloned_in_this_pass;
2091 cloned = (HV *)sv_2mortal((SV *)newHV());
2093 cloned_in_this_pass = FALSE;
2094 for (ix = fpad; ix > 0; ix--) {
2095 PADNAME * const name =
2096 (ix <= fname) ? pname[ix] : NULL;
2097 if (name && name != &PL_padname_undef
2098 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2099 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2101 CV * const protokey = CvOUTSIDE(ppad[ix]);
2102 CV ** const cvp = protokey == proto
2104 : (CV **)hv_fetch(cloned, (char *)&protokey,
2107 S_cv_clone(aTHX_ (CV *)ppad[ix],
2108 (CV *)PL_curpad[ix],
2110 (void)hv_store(cloned, (char *)&ppad[ix],
2112 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2115 cloned_in_this_pass = TRUE;
2119 } while (cloned_in_this_pass);
2121 for (ix = fpad; ix > 0; ix--) {
2122 PADNAME * const name =
2123 (ix <= fname) ? pname[ix] : NULL;
2124 if (name && name != &PL_padname_undef
2125 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2126 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2127 S_cv_clone(aTHX_ (CV *)ppad[ix],
2128 (CV *)PL_curpad[ix],
2129 CvOUTSIDE(ppad[ix]), cloned);
2132 else for (ix = fpad; ix > 0; ix--) {
2133 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2134 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2135 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2136 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2141 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2145 /* Constant sub () { $x } closing over $x:
2146 * The prototype was marked as a candiate for const-ization,
2147 * so try to grab the current const value, and if successful,
2148 * turn into a const sub:
2151 OP *o = CvSTART(cv);
2153 for (; o; o = o->op_next)
2154 if (o->op_type == OP_PADSV)
2156 ASSUME(o->op_type == OP_PADSV);
2157 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2158 /* the candidate should have 1 ref from this pad and 1 ref
2159 * from the parent */
2160 if (const_sv && SvREFCNT(const_sv) == 2) {
2161 const bool was_method = cBOOL(CvMETHOD(cv));
2162 bool copied = FALSE;
2164 PADNAME * const pn =
2165 PadlistNAMESARRAY(CvPADLIST(outside))
2166 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2167 CvPADLIST(cv))[o->op_targ])];
2168 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2170 if (PadnameLVALUE(pn)) {
2171 /* We have a lexical that is potentially modifiable
2172 elsewhere, so making a constant will break clo-
2173 sure behaviour. If this is a ‘simple lexical
2174 op tree’, i.e., sub(){$x}, emit a deprecation
2175 warning, but continue to exhibit the old behav-
2176 iour of making it a constant based on the ref-
2177 count of the candidate variable.
2179 A simple lexical op tree looks like this:
2187 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2191 Perl_ck_warner_d(aTHX_
2192 packWARN(WARN_DEPRECATED),
2193 "Constants from lexical "
2194 "variables potentially "
2195 "modified elsewhere are "
2197 /* We *copy* the lexical variable, and donate the
2198 copy to newCONSTSUB. Yes, this is ugly, and
2199 should be killed. We need to do this for the
2200 time being, however, because turning on SvPADTMP
2201 on a lexical will have observable effects
2203 const_sv = newSVsv(const_sv);
2211 SvREFCNT_inc_simple_void_NN(const_sv);
2212 /* If the lexical is not used elsewhere, it is safe to turn on
2213 SvPADTMP, since it is only when it is used in lvalue con-
2214 text that the difference is observable. */
2215 SvREADONLY_on(const_sv);
2216 SvPADTMP_on(const_sv);
2217 SvREFCNT_dec_NN(cv);
2218 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2232 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2237 const bool newcv = !cv;
2239 assert(!CvUNIQUE(proto));
2241 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2242 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2246 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2249 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2250 else CvGV_set(cv,CvGV(proto));
2251 CvSTASH_set(cv, CvSTASH(proto));
2253 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2255 CvSTART(cv) = CvSTART(proto);
2256 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2259 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2261 SvUTF8_on(MUTABLE_SV(cv));
2264 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2266 if (CvPADLIST(proto))
2267 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2270 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2271 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2272 cv_dump(proto, "Proto");
2280 Perl_cv_clone(pTHX_ CV *proto)
2282 PERL_ARGS_ASSERT_CV_CLONE;
2284 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2285 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2288 /* Called only by pp_clonecv */
2290 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2292 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2294 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2300 Returns an SV containing the name of the CV, mainly for use in error
2301 reporting. The CV may actually be a GV instead, in which case the returned
2302 SV holds the GV's name. Anything other than a GV or CV is treated as a
2303 string already holding the sub name, but this could change in the future.
2305 An SV may be passed as a second argument. If so, the name will be assigned
2306 to it and it will be returned. Otherwise the returned SV will be a new
2309 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2310 included. If the first argument is neither a CV nor a GV, this flag is
2311 ignored (subject to change).
2317 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2319 PERL_ARGS_ASSERT_CV_NAME;
2320 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2321 if (sv) sv_setsv(sv,(SV *)cv);
2322 return sv ? (sv) : (SV *)cv;
2325 SV * const retsv = sv ? (sv) : sv_newmortal();
2326 if (SvTYPE(cv) == SVt_PVCV) {
2328 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2329 sv_sethek(retsv, CvNAME_HEK(cv));
2331 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2332 sv_catpvs(retsv, "::");
2333 sv_cathek(retsv, CvNAME_HEK(cv));
2336 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2337 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2338 else gv_efullname3(retsv, CvGV(cv), NULL);
2340 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2341 else gv_efullname3(retsv,(GV *)cv,NULL);
2347 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2349 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2350 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2351 moved to a pre-existing CV struct.
2357 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2360 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2361 AV * const comppad = PadlistARRAY(padlist)[1];
2362 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2363 SV ** const curpad = AvARRAY(comppad);
2365 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2366 PERL_UNUSED_ARG(old_cv);
2368 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2369 const PADNAME *name = namepad[ix];
2370 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2371 && *PadnamePV(name) == '&')
2373 CV *innercv = MUTABLE_CV(curpad[ix]);
2374 if (UNLIKELY(PadnameOUTER(name))) {
2376 PADNAME **names = namepad;
2378 while (PadnameOUTER(name)) {
2380 names = PadlistNAMESARRAY(CvPADLIST(cv));
2381 i = PARENT_PAD_INDEX(name);
2384 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2386 if (SvTYPE(innercv) == SVt_PVCV) {
2387 /* XXX 0afba48f added code here to check for a proto CV
2388 attached to the pad entry by magic. But shortly there-
2389 after 81df9f6f95 moved the magic to the pad name. The
2390 code here was never updated, so it wasn’t doing anything
2391 and got deleted when PADNAME became a distinct type. Is
2392 there any bug as a result? */
2393 if (CvOUTSIDE(innercv) == old_cv) {
2394 if (!CvWEAKOUTSIDE(innercv)) {
2395 SvREFCNT_dec(old_cv);
2396 SvREFCNT_inc_simple_void_NN(new_cv);
2398 CvOUTSIDE(innercv) = new_cv;
2401 else { /* format reference */
2402 SV * const rv = curpad[ix];
2404 if (!SvOK(rv)) continue;
2406 assert(SvWEAKREF(rv));
2407 innercv = (CV *)SvRV(rv);
2408 assert(!CvWEAKOUTSIDE(innercv));
2409 SvREFCNT_dec(CvOUTSIDE(innercv));
2410 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2417 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2419 Push a new pad frame onto the padlist, unless there's already a pad at
2420 this depth, in which case don't bother creating a new one. Then give
2421 the new pad an C<@_> in slot zero.
2427 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2429 PERL_ARGS_ASSERT_PAD_PUSH;
2431 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2432 PAD** const svp = PadlistARRAY(padlist);
2433 AV* const newpad = newAV();
2434 SV** const oldpad = AvARRAY(svp[depth-1]);
2435 I32 ix = AvFILLp((const AV *)svp[1]);
2436 const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2437 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2440 for ( ;ix > 0; ix--) {
2441 if (names_fill >= ix && PadnameLEN(names[ix])) {
2442 const char sigil = PadnamePV(names[ix])[0];
2443 if (PadnameOUTER(names[ix])
2444 || PadnameIsSTATE(names[ix])
2447 /* outer lexical or anon code */
2448 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2450 else { /* our own lexical */
2453 sv = MUTABLE_SV(newAV());
2454 else if (sigil == '%')
2455 sv = MUTABLE_SV(newHV());
2458 av_store(newpad, ix, sv);
2461 else if (PadnamePV(names[ix])) {
2462 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2465 /* save temporaries on recursion? */
2466 SV * const sv = newSV(0);
2467 av_store(newpad, ix, sv);
2472 av_store(newpad, 0, MUTABLE_SV(av));
2475 padlist_store(padlist, depth, newpad);
2479 #if defined(USE_ITHREADS)
2481 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2484 =for apidoc padlist_dup
2492 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2498 PERL_ARGS_ASSERT_PADLIST_DUP;
2500 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2501 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2503 max = cloneall ? PadlistMAX(srcpad) : 1;
2505 Newx(dstpad, 1, PADLIST);
2506 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2507 PadlistMAX(dstpad) = max;
2508 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2510 PadlistARRAY(dstpad)[0] = (PAD *)
2511 padnamelist_dup(PadlistNAMES(srcpad), param);
2512 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2515 for (depth = 1; depth <= max; ++depth)
2516 PadlistARRAY(dstpad)[depth] =
2517 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2519 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2520 to build anything other than the first level of pads. */
2521 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2523 const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2524 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2525 SV **oldpad = AvARRAY(srcpad1);
2526 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2532 av_extend(pad1, ix);
2533 PadlistARRAY(dstpad)[1] = pad1;
2534 pad1a = AvARRAY(pad1);
2539 for ( ;ix > 0; ix--) {
2542 } else if (names_fill >= ix && names[ix] &&
2543 PadnameLEN(names[ix])) {
2544 const char sigil = PadnamePV(names[ix])[0];
2545 if (PadnameOUTER(names[ix])
2546 || PadnameIsSTATE(names[ix])
2549 /* outer lexical or anon code */
2550 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2552 else { /* our own lexical */
2553 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2554 /* This is a work around for how the current
2555 implementation of ?{ } blocks in regexps
2556 interacts with lexicals. */
2557 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2562 sv = MUTABLE_SV(newAV());
2563 else if (sigil == '%')
2564 sv = MUTABLE_SV(newHV());
2571 else if (( names_fill >= ix && names[ix]
2572 && PadnamePV(names[ix]) )) {
2573 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2576 /* save temporaries on recursion? */
2577 SV * const sv = newSV(0);
2580 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2581 FIXTHAT before merging this branch.
2582 (And I know how to) */
2583 if (SvPADTMP(oldpad[ix]))
2589 args = newAV(); /* Will be @_ */
2591 pad1a[0] = (SV *)args;
2599 #endif /* USE_ITHREADS */
2602 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2605 SSize_t const oldmax = PadlistMAX(padlist);
2607 PERL_ARGS_ASSERT_PADLIST_STORE;
2611 if (key > PadlistMAX(padlist)) {
2612 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2613 (SV ***)&PadlistARRAY(padlist),
2614 (SV ***)&PadlistARRAY(padlist));
2615 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2618 ary = PadlistARRAY(padlist);
2619 SvREFCNT_dec(ary[key]);
2625 =for apidoc newPADNAMELIST
2627 Creates a new pad name list. C<max> is the highest index for which space
2634 Perl_newPADNAMELIST(size_t max)
2637 Newx(pnl, 1, PADNAMELIST);
2638 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2639 PadnamelistMAX(pnl) = -1;
2640 PadnamelistREFCNT(pnl) = 1;
2641 PadnamelistMAXNAMED(pnl) = 0;
2642 pnl->xpadnl_max = max;
2647 =for apidoc padnamelist_store
2649 Stores the pad name (which may be null) at the given index, freeing any
2650 existing pad name in that slot.
2656 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2660 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2664 if (key > pnl->xpadnl_max)
2665 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2666 (SV ***)&PadnamelistARRAY(pnl),
2667 (SV ***)&PadnamelistARRAY(pnl));
2668 if (PadnamelistMAX(pnl) < key) {
2669 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2670 key-PadnamelistMAX(pnl), PADNAME *);
2671 PadnamelistMAX(pnl) = key;
2673 ary = PadnamelistARRAY(pnl);
2675 PadnameREFCNT_dec(ary[key]);
2681 =for apidoc padnamelist_fetch
2683 Fetches the pad name from the given index.
2689 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2691 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2694 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2698 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2700 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2701 if (!--PadnamelistREFCNT(pnl)) {
2702 while(PadnamelistMAX(pnl) >= 0)
2704 PADNAME * const pn =
2705 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2707 PadnameREFCNT_dec(pn);
2709 Safefree(PadnamelistARRAY(pnl));
2714 #if defined(USE_ITHREADS)
2717 =for apidoc padnamelist_dup
2719 Duplicates a pad name list.
2725 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2727 PADNAMELIST *dstpad;
2728 SSize_t max = PadnamelistMAX(srcpad);
2730 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2732 /* look for it in the table first */
2733 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2737 dstpad = newPADNAMELIST(max);
2738 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2739 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2740 PadnamelistMAX(dstpad) = max;
2742 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2743 for (; max >= 0; max--)
2744 if (PadnamelistARRAY(srcpad)[max]) {
2745 PadnamelistARRAY(dstpad)[max] =
2746 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2747 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2753 #endif /* USE_ITHREADS */
2756 =for apidoc newPADNAMEpvn
2758 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2759 use this for pad names that point to outer lexicals. See
2760 C<L</newPADNAMEouter>>.
2766 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2768 struct padname_with_str *alloc;
2769 char *alloc2; /* for Newxz */
2771 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2773 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2775 alloc = (struct padname_with_str *)alloc2;
2776 pn = (PADNAME *)alloc;
2777 PadnameREFCNT(pn) = 1;
2778 PadnamePV(pn) = alloc->xpadn_str;
2779 Copy(s, PadnamePV(pn), len, char);
2780 *(PadnamePV(pn) + len) = '\0';
2781 PadnameLEN(pn) = len;
2786 =for apidoc newPADNAMEouter
2788 Constructs and returns a new pad name. Only use this function for names
2789 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2790 the outer pad name that this one mirrors. The returned pad name has the
2791 C<PADNAMEt_OUTER> flag already set.
2797 Perl_newPADNAMEouter(PADNAME *outer)
2800 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2801 Newxz(pn, 1, PADNAME);
2802 PadnameREFCNT(pn) = 1;
2803 PadnamePV(pn) = PadnamePV(outer);
2804 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2805 another entry. The original pad name owns the buffer. */
2806 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2807 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2808 PadnameLEN(pn) = PadnameLEN(outer);
2813 Perl_padname_free(pTHX_ PADNAME *pn)
2815 PERL_ARGS_ASSERT_PADNAME_FREE;
2816 if (!--PadnameREFCNT(pn)) {
2817 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2818 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2821 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2822 SvREFCNT_dec(PadnameOURSTASH(pn));
2823 if (PadnameOUTER(pn))
2824 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2829 #if defined(USE_ITHREADS)
2832 =for apidoc padname_dup
2834 Duplicates a pad name.
2840 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2844 PERL_ARGS_ASSERT_PADNAME_DUP;
2846 /* look for it in the table first */
2847 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2851 if (!PadnamePV(src)) {
2852 dst = &PL_padname_undef;
2853 ptr_table_store(PL_ptr_table, src, dst);
2857 dst = PadnameOUTER(src)
2858 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2859 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2860 ptr_table_store(PL_ptr_table, src, dst);
2861 PadnameLEN(dst) = PadnameLEN(src);
2862 PadnameFLAGS(dst) = PadnameFLAGS(src);
2863 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2864 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2865 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2867 dst->xpadn_low = src->xpadn_low;
2868 dst->xpadn_high = src->xpadn_high;
2869 dst->xpadn_gen = src->xpadn_gen;
2873 #endif /* USE_ITHREADS */
2876 * ex: set ts=8 sts=4 sw=4 et: