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 && (CvOUTSIDE(innercv) == cv)) {
421 assert(CvWEAKOUTSIDE(innercv));
422 /* don't relink to grandfather if he's being freed */
423 if (outercv && SvREFCNT(outercv)) {
424 CvWEAKOUTSIDE_off(innercv);
425 CvOUTSIDE(innercv) = outercv;
426 CvOUTSIDE_SEQ(innercv) = seq;
427 SvREFCNT_inc_simple_void_NN(outercv);
430 CvOUTSIDE(innercv) = NULL;
437 ix = PadlistMAX(padlist);
439 PAD * const sv = PadlistARRAY(padlist)[ix--];
441 if (sv == PL_comppad) {
449 PADNAMELIST * const names = PadlistNAMES(padlist);
450 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
451 PL_comppad_name = NULL;
452 PadnamelistREFCNT_dec(names);
454 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
456 CvPADLIST_set(&cvbody, NULL);
458 else if (CvISXSUB(&cvbody))
459 CvHSCXT(&cvbody) = NULL;
460 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
463 /* remove CvOUTSIDE unless this is an undef rather than a free */
465 CV * outside = CvOUTSIDE(&cvbody);
467 CvOUTSIDE(&cvbody) = NULL;
468 if (!CvWEAKOUTSIDE(&cvbody))
469 SvREFCNT_dec_NN(outside);
472 if (CvCONST(&cvbody)) {
473 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
474 /* CvCONST_off(cv); *//* turned off below */
476 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
477 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
478 * LEXICAL, which are used to determine the sub's name. */
479 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
484 =for apidoc cv_forget_slab
486 When a CV has a reference count on its slab (CvSLABBED), it is responsible
487 for making sure it is freed. (Hence, no two CVs should ever have a
488 reference count on the same slab.) The CV only needs to reference the slab
489 during compilation. Once it is compiled and CvROOT attached, it has
490 finished its job, so it can forget the slab.
496 Perl_cv_forget_slab(pTHX_ CV *cv)
498 const bool slabbed = !!CvSLABBED(cv);
501 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
503 if (!slabbed) return;
507 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
508 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
510 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
514 #ifdef PERL_DEBUG_READONLY_OPS
515 const size_t refcnt = slab->opslab_refcnt;
517 OpslabREFCNT_dec(slab);
518 #ifdef PERL_DEBUG_READONLY_OPS
519 if (refcnt > 1) Slab_to_ro(slab);
525 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
527 Allocates a place in the currently-compiling
528 pad (via L<perlapi/pad_alloc>) and
529 then stores a name for that entry. I<name> is adopted and
530 becomes the name entry; it must already contain the name
531 string. I<typestash> and I<ourstash> and the C<padadd_STATE>
532 flag get added to I<name>. None of the other
533 processing of L<perlapi/pad_add_name_pvn>
534 is done. Returns the offset of the allocated pad slot.
540 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
543 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
545 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
547 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
550 SvPAD_TYPED_on(name);
552 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
556 SvOURSTASH_set(name, ourstash);
557 SvREFCNT_inc_simple_void_NN(ourstash);
559 else if (flags & padadd_STATE) {
560 SvPAD_STATE_on(name);
563 padnamelist_store(PL_comppad_name, offset, name);
564 PadnamelistMAXNAMED(PL_comppad_name) = offset;
569 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
571 Allocates a place in the currently-compiling pad for a named lexical
572 variable. Stores the name and other metadata in the name part of the
573 pad, and makes preparations to manage the variable's lexical scoping.
574 Returns the offset of the allocated pad slot.
576 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
577 If I<typestash> is non-null, the name is for a typed lexical, and this
578 identifies the type. If I<ourstash> is non-null, it's a lexical reference
579 to a package variable, and this identifies the package. The following
580 flags can be OR'ed together:
582 padadd_OUR redundantly specifies if it's a package var
583 padadd_STATE variable will retain value persistently
584 padadd_NO_DUP_CHECK skip check for lexical shadowing
590 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
591 U32 flags, HV *typestash, HV *ourstash)
596 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
598 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
599 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
602 name = newPADNAMEpvn(namepv, namelen);
604 if ((flags & padadd_NO_DUP_CHECK) == 0) {
606 SAVEFREEPADNAME(name); /* in case of fatal warnings */
607 /* check for duplicate declaration */
608 pad_check_dup(name, flags & padadd_OUR, ourstash);
609 PadnameREFCNT(name)++;
613 offset = pad_alloc_name(name, flags, typestash, ourstash);
615 /* not yet introduced */
616 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
617 COP_SEQ_RANGE_HIGH_set(name, 0);
619 if (!PL_min_intro_pending)
620 PL_min_intro_pending = offset;
621 PL_max_intro_pending = offset;
622 /* if it's not a simple scalar, replace with an AV or HV */
623 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
624 assert(SvREFCNT(PL_curpad[offset]) == 1);
625 if (namelen != 0 && *namepv == '@')
626 sv_upgrade(PL_curpad[offset], SVt_PVAV);
627 else if (namelen != 0 && *namepv == '%')
628 sv_upgrade(PL_curpad[offset], SVt_PVHV);
629 else if (namelen != 0 && *namepv == '&')
630 sv_upgrade(PL_curpad[offset], SVt_PVCV);
631 assert(SvPADMY(PL_curpad[offset]));
632 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
633 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
634 (long)offset, PadnamePV(name),
635 PTR2UV(PL_curpad[offset])));
641 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
643 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
644 instead of a string/length pair.
650 Perl_pad_add_name_pv(pTHX_ const char *name,
651 const U32 flags, HV *typestash, HV *ourstash)
653 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
654 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
658 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
660 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
661 of an SV instead of a string/length pair.
667 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
671 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
672 namepv = SvPVutf8(name, namelen);
673 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
677 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
679 Allocates a place in the currently-compiling pad,
680 returning the offset of the allocated pad slot.
681 No name is initially attached to the pad slot.
682 I<tmptype> is a set of flags indicating the kind of pad entry required,
683 which will be set in the value SV for the allocated pad entry:
685 SVs_PADMY named lexical variable ("my", "our", "state")
686 SVs_PADTMP unnamed temporary store
687 SVf_READONLY constant shared between recursion levels
689 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
690 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
691 does not cause the SV in the pad slot to be marked read-only, but simply
692 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
693 least should be treated as such.
695 I<optype> should be an opcode indicating the type of operation that the
696 pad entry is to support. This doesn't affect operational semantics,
697 but is used for debugging.
702 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
703 * or at least rationalise ??? */
706 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
711 PERL_UNUSED_ARG(optype);
712 ASSERT_CURPAD_ACTIVE("pad_alloc");
714 if (AvARRAY(PL_comppad) != PL_curpad)
715 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
716 AvARRAY(PL_comppad), PL_curpad);
717 if (PL_pad_reset_pending)
719 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
720 /* For a my, simply push a null SV onto the end of PL_comppad. */
721 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
722 retval = AvFILLp(PL_comppad);
725 /* For a tmp, scan the pad from PL_padix upwards
726 * for a slot which has no name and no active value.
727 * For a constant, likewise, but use PL_constpadix.
729 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
730 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
731 const bool konst = cBOOL(tmptype & SVf_READONLY);
732 retval = konst ? PL_constpadix : PL_padix;
735 * Entries that close over unavailable variables
736 * in outer subs contain values not marked PADMY.
737 * Thus we must skip, not just pad values that are
738 * marked as current pad values, but also those with names.
739 * If pad_reset is enabled, ‘current’ means different
740 * things depending on whether we are allocating a con-
741 * stant or a target. For a target, things marked PADTMP
742 * can be reused; not so for constants.
745 if (++retval <= names_fill &&
746 (pn = names[retval]) && PadnamePV(pn))
748 sv = *av_fetch(PL_comppad, retval, TRUE);
751 (konst ? SVs_PADTMP : 0))
759 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
760 tmptype &= ~SVf_READONLY;
761 tmptype |= SVs_PADTMP;
763 *(konst ? &PL_constpadix : &PL_padix) = retval;
765 SvFLAGS(sv) |= tmptype;
766 PL_curpad = AvARRAY(PL_comppad);
768 DEBUG_X(PerlIO_printf(Perl_debug_log,
769 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
770 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
771 PL_op_name[optype]));
772 #ifdef DEBUG_LEAKING_SCALARS
773 sv->sv_debug_optype = optype;
774 sv->sv_debug_inpad = 1;
776 return (PADOFFSET)retval;
780 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
782 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
783 for an anonymous function that is lexically scoped inside the
784 currently-compiling function.
785 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
786 to the outer scope is weakened to avoid a reference loop.
788 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
790 I<optype> should be an opcode indicating the type of operation that the
791 pad entry is to support. This doesn't affect operational semantics,
792 but is used for debugging.
798 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
801 PADNAME * const name = newPADNAMEpvn("&", 1);
803 PERL_ARGS_ASSERT_PAD_ADD_ANON;
806 /* These two aren't used; just make sure they're not equal to
807 * PERL_PADSEQ_INTRO. They should be 0 by default. */
808 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
809 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
810 ix = pad_alloc(optype, SVs_PADMY);
811 padnamelist_store(PL_comppad_name, ix, name);
812 /* XXX DAPM use PL_curpad[] ? */
813 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
814 av_store(PL_comppad, ix, (SV*)func);
816 SV *rv = newRV_noinc((SV *)func);
818 assert (SvTYPE(func) == SVt_PVFM);
819 av_store(PL_comppad, ix, rv);
822 /* to avoid ref loops, we never have parent + child referencing each
823 * other simultaneously */
824 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
825 assert(!CvWEAKOUTSIDE(func));
826 CvWEAKOUTSIDE_on(func);
827 SvREFCNT_dec_NN(CvOUTSIDE(func));
833 =for apidoc pad_check_dup
835 Check for duplicate declarations: report any of:
837 * a my in the current scope with the same name;
838 * an our (anywhere in the pad) with the same name and the
839 same stash as C<ourstash>
841 C<is_our> indicates that the name to check is an 'our' declaration.
847 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
851 const U32 is_our = flags & padadd_OUR;
853 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
855 ASSERT_CURPAD_ACTIVE("pad_check_dup");
857 assert((flags & ~padadd_OUR) == 0);
859 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
860 return; /* nothing to check */
862 svp = PadnamelistARRAY(PL_comppad_name);
863 top = PadnamelistMAX(PL_comppad_name);
864 /* check the current scope */
865 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
867 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
868 PADNAME * const sv = svp[off];
870 && PadnameLEN(sv) == PadnameLEN(name)
872 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
873 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
874 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
876 if (is_our && (SvPAD_OUR(sv)))
877 break; /* "our" masking "our" */
878 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
879 Perl_warner(aTHX_ packWARN(WARN_MISC),
880 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
881 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
882 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
884 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
885 ? "scope" : "statement"));
890 /* check the rest of the pad */
893 PADNAME * const sv = svp[off];
895 && PadnameLEN(sv) == PadnameLEN(name)
897 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
898 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
899 && SvOURSTASH(sv) == ourstash
900 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
902 Perl_warner(aTHX_ packWARN(WARN_MISC),
903 "\"our\" variable %"PNf" redeclared", PNfARG(sv));
904 if ((I32)off <= PL_comppad_name_floor)
905 Perl_warner(aTHX_ packWARN(WARN_MISC),
906 "\t(Did you mean \"local\" instead of \"our\"?)\n");
916 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
918 Given the name of a lexical variable, find its position in the
919 currently-compiling pad.
920 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
921 I<flags> is reserved and must be zero.
922 If it is not in the current pad but appears in the pad of any lexically
923 enclosing scope, then a pseudo-entry for it is added in the current pad.
924 Returns the offset in the current pad,
925 or C<NOT_IN_PAD> if no such lexical is in scope.
931 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
936 const PADNAMELIST *namelist;
939 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
941 pad_peg("pad_findmy_pvn");
944 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
947 offset = pad_findlex(namepv, namelen, flags,
948 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
949 if ((PADOFFSET)offset != NOT_IN_PAD)
952 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
954 if (*namepv == '&') return NOT_IN_PAD;
956 /* look for an our that's being introduced; this allows
957 * our $foo = 0 unless defined $foo;
958 * to not give a warning. (Yes, this is a hack) */
960 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
961 name_p = PadnamelistARRAY(namelist);
962 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
963 const PADNAME * const name = name_p[offset];
964 if (name && PadnameLEN(name) == namelen
965 && !PadnameOUTER(name)
966 && (PadnameIsOUR(name))
967 && ( PadnamePV(name) == namepv
968 || memEQ(PadnamePV(name), namepv, namelen) )
969 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
977 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
979 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
980 instead of a string/length pair.
986 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
988 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
989 return pad_findmy_pvn(name, strlen(name), flags);
993 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
995 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
996 of an SV instead of a string/length pair.
1002 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1006 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1007 namepv = SvPVutf8(name, namelen);
1008 return pad_findmy_pvn(namepv, namelen, flags);
1012 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1014 Find the position of the lexical C<$_> in the pad of the
1015 currently-executing function. Returns the offset in the current pad,
1016 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1017 the global one should be used instead).
1018 L</find_rundefsv> is likely to be more convenient.
1024 Perl_find_rundefsvoffset(pTHX)
1028 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1029 NULL, &out_pn, &out_flags);
1033 =for apidoc Am|SV *|find_rundefsv
1035 Find and return the variable that is named C<$_> in the lexical scope
1036 of the currently-executing function. This may be a lexical C<$_>,
1037 or will otherwise be the global one.
1043 Perl_find_rundefsv(pTHX)
1049 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1050 NULL, &name, &flags);
1052 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1059 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1065 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1067 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1068 NULL, &name, &flags);
1070 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1073 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1077 =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
1079 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1080 in the inner pads if it's found in an outer one.
1082 Returns the offset in the bottom pad of the lex or the fake lex.
1083 cv is the CV in which to start the search, and seq is the current cop_seq
1084 to match against. If warn is true, print appropriate warnings. The out_*
1085 vars return values, and so are pointers to where the returned values
1086 should be stored. out_capture, if non-null, requests that the innermost
1087 instance of the lexical is captured; out_name is set to the innermost
1088 matched pad name or fake pad name; out_flags returns the flags normally
1089 associated with the PARENT_FAKELEX_FLAGS field of a fake pad name.
1091 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1092 then comes back down, adding fake entries
1093 as it goes. It has to be this way
1094 because fake names in anon protoypes have to store in xlow the index into
1100 /* the CV has finished being compiled. This is not a sufficient test for
1101 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1102 #define CvCOMPILED(cv) CvROOT(cv)
1104 /* the CV does late binding of its lexicals */
1105 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1108 S_unavailable(pTHX_ PADNAME *name)
1110 /* diag_listed_as: Variable "%s" is not available */
1111 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1112 "%se \"%"PNf"\" is not available",
1113 *PadnamePV(name) == '&'
1120 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1121 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1123 I32 offset, new_offset;
1126 const PADLIST * const padlist = CvPADLIST(cv);
1127 const bool staleok = !!(flags & padadd_STALEOK);
1129 PERL_ARGS_ASSERT_PAD_FINDLEX;
1131 flags &= ~ padadd_STALEOK; /* one-shot flag */
1133 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1138 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1139 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1140 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1141 out_capture ? " capturing" : "" ));
1143 /* first, search this pad */
1145 if (padlist) { /* not an undef CV */
1146 I32 fake_offset = 0;
1147 const PADNAMELIST * const names = PadlistNAMES(padlist);
1148 PADNAME * const * const name_p = PadnamelistARRAY(names);
1150 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1151 const PADNAME * const name = name_p[offset];
1152 if (name && PadnameLEN(name) == namelen
1153 && ( PadnamePV(name) == namepv
1154 || memEQ(PadnamePV(name), namepv, namelen) ))
1156 if (PadnameOUTER(name)) {
1157 fake_offset = offset; /* in case we don't find a real one */
1160 if (PadnameIN_SCOPE(name, seq))
1165 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1166 if (offset > 0) { /* not fake */
1168 *out_name = name_p[offset]; /* return the name */
1170 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1171 * instances. For now, we just test !CvUNIQUE(cv), but
1172 * ideally, we should detect my's declared within loops
1173 * etc - this would allow a wider range of 'not stayed
1174 * shared' warnings. We also treated already-compiled
1175 * lexes as not multi as viewed from evals. */
1177 *out_flags = CvANON(cv) ?
1179 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1180 ? PAD_FAKELEX_MULTI : 0;
1182 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1183 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1184 PTR2UV(cv), (long)offset,
1185 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1186 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1188 else { /* fake match */
1189 offset = fake_offset;
1190 *out_name = name_p[offset]; /* return the name */
1191 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1192 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1193 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1194 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1195 (unsigned long) PARENT_PAD_INDEX(*out_name)
1199 /* return the lex? */
1204 if (PadnameIsOUR(*out_name)) {
1205 *out_capture = NULL;
1209 /* trying to capture from an anon prototype? */
1211 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1212 : *out_flags & PAD_FAKELEX_ANON)
1218 *out_capture = NULL;
1224 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1225 && !PadnameIsSTATE(name_p[offset])
1226 && warn && ckWARN(WARN_CLOSURE)) {
1228 /* diag_listed_as: Variable "%s" will not stay
1230 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1231 "%se \"%"UTF8f"\" will not stay shared",
1232 *namepv == '&' ? "Subroutin" : "Variabl",
1233 UTF8fARG(1, namelen, namepv));
1236 if (fake_offset && CvANON(cv)
1237 && CvCLONE(cv) &&!CvCLONED(cv))
1240 /* not yet caught - look further up */
1241 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1242 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1245 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1247 newwarn, out_capture, out_name, out_flags);
1252 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1253 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1254 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1255 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1256 PTR2UV(cv), PTR2UV(*out_capture)));
1258 if (SvPADSTALE(*out_capture)
1259 && (!CvDEPTH(cv) || !staleok)
1260 && !PadnameIsSTATE(name_p[offset]))
1264 *out_capture = NULL;
1267 if (!*out_capture) {
1268 if (namelen != 0 && *namepv == '@')
1269 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1270 else if (namelen != 0 && *namepv == '%')
1271 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1272 else if (namelen != 0 && *namepv == '&')
1273 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1275 *out_capture = sv_newmortal();
1283 /* it's not in this pad - try above */
1288 /* out_capture non-null means caller wants us to capture lex; in
1289 * addition we capture ourselves unless it's an ANON/format */
1290 new_capturep = out_capture ? out_capture :
1291 CvLATE(cv) ? NULL : &new_capture;
1293 offset = pad_findlex(namepv, namelen,
1294 flags | padadd_STALEOK*(new_capturep == &new_capture),
1295 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1296 new_capturep, out_name, out_flags);
1297 if ((PADOFFSET)offset == NOT_IN_PAD)
1300 /* found in an outer CV. Add appropriate fake entry to this pad */
1302 /* don't add new fake entries (via eval) to CVs that we have already
1303 * finished compiling, or to undef CVs */
1304 if (CvCOMPILED(cv) || !padlist)
1305 return 0; /* this dummy (and invalid) value isnt used by the caller */
1308 /* This relies on sv_setsv_flags() upgrading the destination to the same
1309 type as the source, independent of the flags set, and on it being
1310 "good" and only copying flag bits and pointers that it understands.
1312 PADNAME *new_name = newPADNAMEouter(*out_name);
1313 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1314 PAD * const ocomppad = PL_comppad;
1315 PL_comppad_name = PadlistNAMES(padlist);
1316 PL_comppad = PadlistARRAY(padlist)[1];
1317 PL_curpad = AvARRAY(PL_comppad);
1320 = pad_alloc_name(new_name,
1321 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1322 PadnameTYPE(*out_name),
1323 PadnameOURSTASH(*out_name)
1326 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1327 "Pad addname: %ld \"%.*s\" FAKE\n",
1329 (int) PadnameLEN(new_name),
1330 PadnamePV(new_name)));
1331 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1333 PARENT_PAD_INDEX_set(new_name, 0);
1334 if (PadnameIsOUR(new_name)) {
1335 NOOP; /* do nothing */
1337 else if (CvLATE(cv)) {
1338 /* delayed creation - just note the offset within parent pad */
1339 PARENT_PAD_INDEX_set(new_name, offset);
1343 /* immediate creation - capture outer value right now */
1344 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1345 /* But also note the offset, as newMYSUB needs it */
1346 PARENT_PAD_INDEX_set(new_name, offset);
1347 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1348 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1349 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1351 *out_name = new_name;
1352 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1354 PL_comppad_name = ocomppad_name;
1355 PL_comppad = ocomppad;
1356 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1364 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1366 Get the value at offset I<po> in the current (compiling or executing) pad.
1367 Use macro PAD_SV instead of calling this function directly.
1373 Perl_pad_sv(pTHX_ PADOFFSET po)
1375 ASSERT_CURPAD_ACTIVE("pad_sv");
1378 Perl_croak(aTHX_ "panic: pad_sv po");
1379 DEBUG_X(PerlIO_printf(Perl_debug_log,
1380 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1381 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1383 return PL_curpad[po];
1387 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1389 Set the value at offset I<po> in the current (compiling or executing) pad.
1390 Use the macro PAD_SETSV() rather than calling this function directly.
1396 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1398 PERL_ARGS_ASSERT_PAD_SETSV;
1400 ASSERT_CURPAD_ACTIVE("pad_setsv");
1402 DEBUG_X(PerlIO_printf(Perl_debug_log,
1403 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1404 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1409 #endif /* DEBUGGING */
1412 =for apidoc m|void|pad_block_start|int full
1414 Update the pad compilation state variables on entry to a new block.
1419 /* XXX DAPM perhaps:
1420 * - integrate this in general state-saving routine ???
1421 * - combine with the state-saving going on in pad_new ???
1422 * - introduce a new SAVE type that does all this in one go ?
1426 Perl_pad_block_start(pTHX_ int full)
1428 ASSERT_CURPAD_ACTIVE("pad_block_start");
1429 SAVEI32(PL_comppad_name_floor);
1430 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1432 PL_comppad_name_fill = PL_comppad_name_floor;
1433 if (PL_comppad_name_floor < 0)
1434 PL_comppad_name_floor = 0;
1435 SAVEI32(PL_min_intro_pending);
1436 SAVEI32(PL_max_intro_pending);
1437 PL_min_intro_pending = 0;
1438 SAVEI32(PL_comppad_name_fill);
1439 SAVEI32(PL_padix_floor);
1440 /* PL_padix_floor is what PL_padix is reset to at the start of each
1441 statement, by pad_reset(). We set it when entering a new scope
1442 to keep things like this working:
1443 print "$foo$bar", do { this(); that() . "foo" };
1444 We must not let "$foo$bar" and the later concatenation share the
1446 PL_padix_floor = PL_padix;
1447 PL_pad_reset_pending = FALSE;
1451 =for apidoc Am|U32|intro_my
1453 "Introduce" C<my> variables to visible status. This is called during parsing
1454 at the end of each statement to make lexical variables visible to subsequent
1467 ASSERT_CURPAD_ACTIVE("intro_my");
1468 if (PL_compiling.cop_seq) {
1469 seq = PL_compiling.cop_seq;
1470 PL_compiling.cop_seq = 0;
1473 seq = PL_cop_seqmax;
1474 if (! PL_min_intro_pending)
1477 svp = PadnamelistARRAY(PL_comppad_name);
1478 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1479 PADNAME * const sv = svp[i];
1481 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1482 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1484 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1485 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1486 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1487 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1488 (long)i, PadnamePV(sv),
1489 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1490 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1495 PL_min_intro_pending = 0;
1496 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1497 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1498 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1504 =for apidoc m|void|pad_leavemy
1506 Cleanup at end of scope during compilation: set the max seq number for
1507 lexicals in this scope and warn of any lexicals that never got introduced.
1513 Perl_pad_leavemy(pTHX)
1517 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1519 PL_pad_reset_pending = FALSE;
1521 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1522 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1523 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1524 const PADNAME * const name = svp[off];
1525 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1526 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1527 "%"PNf" never introduced",
1531 /* "Deintroduce" my variables that are leaving with this scope. */
1532 for (off = PadnamelistMAX(PL_comppad_name);
1533 off > PL_comppad_name_fill; off--) {
1534 PADNAME * const sv = svp[off];
1535 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1536 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1538 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1541 (long)off, PadnamePV(sv),
1542 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1543 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1545 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1546 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1547 OP *kid = newOP(OP_INTROCV, 0);
1549 o = op_prepend_elem(OP_LINESEQ, kid, o);
1554 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1555 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1560 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1562 Abandon the tmp in the current pad at offset po and replace with a
1569 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1571 ASSERT_CURPAD_LEGAL("pad_swipe");
1574 if (AvARRAY(PL_comppad) != PL_curpad)
1575 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1576 AvARRAY(PL_comppad), PL_curpad);
1577 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1578 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1579 (long)po, (long)AvFILLp(PL_comppad));
1581 DEBUG_X(PerlIO_printf(Perl_debug_log,
1582 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1583 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1586 SvREFCNT_dec(PL_curpad[po]);
1589 /* if pad tmps aren't shared between ops, then there's no need to
1590 * create a new tmp when an existing op is freed */
1591 #ifdef USE_PAD_RESET
1592 PL_curpad[po] = newSV(0);
1593 SvPADTMP_on(PL_curpad[po]);
1595 PL_curpad[po] = NULL;
1597 if (PadnamelistMAX(PL_comppad_name) != -1
1598 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1599 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1600 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1602 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1604 /* Use PL_constpadix here, not PL_padix. The latter may have been
1605 reset by pad_reset. We don’t want pad_alloc to have to scan the
1606 whole pad when allocating a constant. */
1607 if ((I32)po < PL_constpadix)
1608 PL_constpadix = po - 1;
1612 =for apidoc m|void|pad_reset
1614 Mark all the current temporaries for reuse
1619 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1620 * between OPs from different statements. During compilation, at the start
1621 * of each statement pad_reset resets PL_padix back to its previous value.
1622 * When allocating a target, pad_alloc begins its scan through the pad at
1627 #ifdef USE_PAD_RESET
1628 if (AvARRAY(PL_comppad) != PL_curpad)
1629 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1630 AvARRAY(PL_comppad), PL_curpad);
1632 DEBUG_X(PerlIO_printf(Perl_debug_log,
1633 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1634 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1635 (long)PL_padix, (long)PL_padix_floor
1639 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1640 PL_padix = PL_padix_floor;
1643 PL_pad_reset_pending = FALSE;
1647 =for apidoc Amx|void|pad_tidy|padtidy_type type
1649 Tidy up a pad at the end of compilation of the code to which it belongs.
1650 Jobs performed here are: remove most stuff from the pads of anonsub
1651 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1652 the kind of subroutine:
1654 padtidy_SUB ordinary subroutine
1655 padtidy_SUBCLONE prototype for lexical closure
1656 padtidy_FORMAT format
1661 /* XXX DAPM surely most of this stuff should be done properly
1662 * at the right time beforehand, rather than going around afterwards
1663 * cleaning up our mistakes ???
1667 Perl_pad_tidy(pTHX_ padtidy_type type)
1671 ASSERT_CURPAD_ACTIVE("pad_tidy");
1673 /* If this CV has had any 'eval-capable' ops planted in it:
1674 * i.e. it contains any of:
1678 * * use re 'eval'; /$var/
1681 * Then any anon prototypes in the chain of CVs should be marked as
1682 * cloneable, so that for example the eval's CV in
1686 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1687 * potentially have an eval executed within it.
1690 if (PL_cv_has_eval || PL_perldb) {
1692 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1693 if (cv != PL_compcv && CvCOMPILED(cv))
1694 break; /* no need to mark already-compiled code */
1696 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1697 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1704 /* extend namepad to match curpad */
1705 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1706 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1708 if (type == padtidy_SUBCLONE) {
1709 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1712 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1714 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1717 * The only things that a clonable function needs in its
1718 * pad are anonymous subs, constants and GVs.
1719 * The rest are created anew during cloning.
1721 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1724 if (!(PadnamePV(namesv) &&
1725 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1727 SvREFCNT_dec(PL_curpad[ix]);
1728 PL_curpad[ix] = NULL;
1732 else if (type == padtidy_SUB) {
1733 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1734 AV * const av = newAV(); /* Will be @_ */
1735 av_store(PL_comppad, 0, MUTABLE_SV(av));
1739 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1740 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1742 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1743 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1744 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1746 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1747 /* This is a work around for how the current implementation of
1748 ?{ } blocks in regexps interacts with lexicals.
1750 One of our lexicals.
1751 Can't do this on all lexicals, otherwise sub baz() won't
1760 because completion of compiling &bar calling pad_tidy()
1761 would cause (top level) $foo to be marked as stale, and
1762 "no longer available". */
1763 SvPADSTALE_on(PL_curpad[ix]);
1767 PL_curpad = AvARRAY(PL_comppad);
1771 =for apidoc m|void|pad_free|PADOFFSET po
1773 Free the SV at offset po in the current pad.
1778 /* XXX DAPM integrate with pad_swipe ???? */
1780 Perl_pad_free(pTHX_ PADOFFSET po)
1782 #ifndef USE_PAD_RESET
1785 ASSERT_CURPAD_LEGAL("pad_free");
1788 if (AvARRAY(PL_comppad) != PL_curpad)
1789 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1790 AvARRAY(PL_comppad), PL_curpad);
1792 Perl_croak(aTHX_ "panic: pad_free po");
1794 DEBUG_X(PerlIO_printf(Perl_debug_log,
1795 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1796 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1799 #ifndef USE_PAD_RESET
1801 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1802 SvFLAGS(sv) &= ~SVs_PADTMP;
1804 if ((I32)po < PL_padix)
1810 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1812 Dump the contents of a padlist
1818 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1820 const PADNAMELIST *pad_name;
1826 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1831 pad_name = PadlistNAMES(padlist);
1832 pad = PadlistARRAY(padlist)[1];
1833 pname = PadnamelistARRAY(pad_name);
1834 ppad = AvARRAY(pad);
1835 Perl_dump_indent(aTHX_ level, file,
1836 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1837 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1840 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1841 const PADNAME *namesv = pname[ix];
1842 if (namesv && !PadnameLEN(namesv)) {
1846 if (PadnameOUTER(namesv))
1847 Perl_dump_indent(aTHX_ level+1, file,
1848 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1851 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1853 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1854 (unsigned long)PARENT_PAD_INDEX(namesv)
1858 Perl_dump_indent(aTHX_ level+1, file,
1859 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1862 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1863 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1864 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1869 Perl_dump_indent(aTHX_ level+1, file,
1870 "%2d. 0x%"UVxf"<%lu>\n",
1873 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1882 =for apidoc m|void|cv_dump|CV *cv|const char *title
1884 dump the contents of a CV
1890 S_cv_dump(pTHX_ const CV *cv, const char *title)
1892 const CV * const outside = CvOUTSIDE(cv);
1893 PADLIST* const padlist = CvPADLIST(cv);
1895 PERL_ARGS_ASSERT_CV_DUMP;
1897 PerlIO_printf(Perl_debug_log,
1898 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1901 (CvANON(cv) ? "ANON"
1902 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1903 : (cv == PL_main_cv) ? "MAIN"
1904 : CvUNIQUE(cv) ? "UNIQUE"
1905 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1908 : CvANON(outside) ? "ANON"
1909 : (outside == PL_main_cv) ? "MAIN"
1910 : CvUNIQUE(outside) ? "UNIQUE"
1911 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1913 PerlIO_printf(Perl_debug_log,
1914 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1915 do_dump_pad(1, Perl_debug_log, padlist, 1);
1918 #endif /* DEBUGGING */
1921 =for apidoc Am|CV *|cv_clone|CV *proto
1923 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1924 of the function: its code, pad structure, and other attributes.
1925 The prototype is combined with a capture of outer lexicals to which the
1926 code refers, which are taken from the currently-executing instance of
1927 the immediately surrounding code.
1932 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1935 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1938 PADLIST* const protopadlist = CvPADLIST(proto);
1939 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1940 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1941 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1942 SV** const ppad = AvARRAY(protopad);
1943 const I32 fname = PadnamelistMAX(protopad_name);
1944 const I32 fpad = AvFILLp(protopad);
1947 bool subclones = FALSE;
1949 assert(!CvUNIQUE(proto));
1951 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1952 * reliable. The currently-running sub is always the one we need to
1954 * For my subs, the currently-running sub may not be the one we want.
1955 * We have to check whether it is a clone of CvOUTSIDE.
1956 * Note that in general for formats, CvOUTSIDE != find_runcv.
1957 * Since formats may be nested inside closures, CvOUTSIDE may point
1958 * to a prototype; we instead want the cloned parent who called us.
1962 if (CvWEAKOUTSIDE(proto))
1963 outside = find_runcv(NULL);
1965 outside = CvOUTSIDE(proto);
1966 if ((CvCLONE(outside) && ! CvCLONED(outside))
1967 || !CvPADLIST(outside)
1968 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1969 outside = find_runcv_where(
1970 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1972 /* outside could be null */
1976 depth = outside ? CvDEPTH(outside) : 0;
1981 SAVESPTR(PL_compcv);
1983 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1986 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1988 SAVESPTR(PL_comppad_name);
1989 PL_comppad_name = protopad_name;
1990 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1991 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1993 av_fill(PL_comppad, fpad);
1995 PL_curpad = AvARRAY(PL_comppad);
1997 outpad = outside && CvPADLIST(outside)
1998 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2000 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2002 for (ix = fpad; ix > 0; ix--) {
2003 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
2005 if (namesv && PadnameLEN(namesv)) { /* lexical */
2006 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2010 if (PadnameOUTER(namesv)) { /* lexical from outside? */
2011 /* formats may have an inactive, or even undefined, parent;
2012 but state vars are always available. */
2013 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2014 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2015 && (!outside || !CvDEPTH(outside))) ) {
2016 S_unavailable(aTHX_ namesv);
2020 SvREFCNT_inc_simple_void_NN(sv);
2023 const char sigil = PadnamePV(namesv)[0];
2025 /* If there are state subs, we need to clone them, too.
2026 But they may need to close over variables we have
2027 not cloned yet. So we will have to do a second
2028 pass. Furthermore, there may be state subs clos-
2029 ing over other state subs’ entries, so we have
2030 to put a stub here and then clone into it on the
2032 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2033 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2035 sv = newSV_type(SVt_PVCV);
2038 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2041 /* Just provide a stub, but name it. It will be
2042 upgrade to the real thing on scope entry. */
2045 PERL_HASH(hash, PadnamePV(namesv)+1,
2046 PadnameLEN(namesv) - 1);
2047 sv = newSV_type(SVt_PVCV);
2050 share_hek(PadnamePV(namesv)+1,
2051 1 - PadnameLEN(namesv),
2056 else sv = SvREFCNT_inc(ppad[ix]);
2057 else if (sigil == '@')
2058 sv = MUTABLE_SV(newAV());
2059 else if (sigil == '%')
2060 sv = MUTABLE_SV(newHV());
2063 /* reset the 'assign only once' flag on each state var */
2064 if (sigil != '&' && SvPAD_STATE(namesv))
2069 else if (namesv && PadnamePV(namesv)) {
2070 sv = SvREFCNT_inc_NN(ppad[ix]);
2080 for (ix = fpad; ix > 0; ix--) {
2081 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2082 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2083 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2084 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2087 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2091 /* Constant sub () { $x } closing over $x:
2092 * The prototype was marked as a candiate for const-ization,
2093 * so try to grab the current const value, and if successful,
2094 * turn into a const sub:
2097 OP *o = CvSTART(cv);
2099 for (; o; o = o->op_next)
2100 if (o->op_type == OP_PADSV)
2102 ASSUME(o->op_type == OP_PADSV);
2103 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2104 /* the candidate should have 1 ref from this pad and 1 ref
2105 * from the parent */
2106 if (const_sv && SvREFCNT(const_sv) == 2) {
2107 const bool was_method = cBOOL(CvMETHOD(cv));
2108 bool copied = FALSE;
2110 PADNAME * const pn =
2111 PadlistNAMESARRAY(CvPADLIST(outside))
2112 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2113 CvPADLIST(cv))[o->op_targ])];
2114 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2116 if (PadnameLVALUE(pn)) {
2117 /* We have a lexical that is potentially modifiable
2118 elsewhere, so making a constant will break clo-
2119 sure behaviour. If this is a ‘simple lexical
2120 op tree’, i.e., sub(){$x}, emit a deprecation
2121 warning, but continue to exhibit the old behav-
2122 iour of making it a constant based on the ref-
2123 count of the candidate variable.
2125 A simple lexical op tree looks like this:
2133 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2137 Perl_ck_warner_d(aTHX_
2138 packWARN(WARN_DEPRECATED),
2139 "Constants from lexical "
2140 "variables potentially "
2141 "modified elsewhere are "
2143 /* We *copy* the lexical variable, and donate the
2144 copy to newCONSTSUB. Yes, this is ugly, and
2145 should be killed. We need to do this for the
2146 time being, however, because turning on SvPADTMP
2147 on a lexical will have observable effects
2149 const_sv = newSVsv(const_sv);
2157 SvREFCNT_inc_simple_void_NN(const_sv);
2158 /* If the lexical is not used elsewhere, it is safe to turn on
2159 SvPADTMP, since it is only when it is used in lvalue con-
2160 text that the difference is observable. */
2161 SvREADONLY_on(const_sv);
2162 SvPADTMP_on(const_sv);
2163 SvREFCNT_dec_NN(cv);
2164 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2178 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2183 const bool newcv = !cv;
2185 assert(!CvUNIQUE(proto));
2187 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2188 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2192 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2195 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2196 else CvGV_set(cv,CvGV(proto));
2197 CvSTASH_set(cv, CvSTASH(proto));
2199 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2201 CvSTART(cv) = CvSTART(proto);
2202 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2205 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2207 SvUTF8_on(MUTABLE_SV(cv));
2210 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2212 if (CvPADLIST(proto))
2213 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2216 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2217 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2218 cv_dump(proto, "Proto");
2226 Perl_cv_clone(pTHX_ CV *proto)
2228 PERL_ARGS_ASSERT_CV_CLONE;
2230 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2231 return S_cv_clone(aTHX_ proto, NULL, NULL);
2234 /* Called only by pp_clonecv */
2236 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2238 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2240 return S_cv_clone(aTHX_ proto, target, NULL);
2246 Returns an SV containing the name of the CV, mainly for use in error
2247 reporting. The CV may actually be a GV instead, in which case the returned
2248 SV holds the GV's name. Anything other than a GV or CV is treated as a
2249 string already holding the sub name, but this could change in the future.
2251 An SV may be passed as a second argument. If so, the name will be assigned
2252 to it and it will be returned. Otherwise the returned SV will be a new
2255 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2256 included. If the first argument is neither a CV nor a GV, this flag is
2257 ignored (subject to change).
2263 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2265 PERL_ARGS_ASSERT_CV_NAME;
2266 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2267 if (sv) sv_setsv(sv,(SV *)cv);
2268 return sv ? (sv) : (SV *)cv;
2271 SV * const retsv = sv ? (sv) : sv_newmortal();
2272 if (SvTYPE(cv) == SVt_PVCV) {
2274 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2275 sv_sethek(retsv, CvNAME_HEK(cv));
2277 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2278 sv_catpvs(retsv, "::");
2279 sv_cathek(retsv, CvNAME_HEK(cv));
2282 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2283 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2284 else gv_efullname3(retsv, CvGV(cv), NULL);
2286 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2287 else gv_efullname3(retsv,(GV *)cv,NULL);
2293 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2295 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2296 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2297 moved to a pre-existing CV struct.
2303 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2306 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2307 AV * const comppad = PadlistARRAY(padlist)[1];
2308 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2309 SV ** const curpad = AvARRAY(comppad);
2311 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2312 PERL_UNUSED_ARG(old_cv);
2314 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2315 const PADNAME * const name = namepad[ix];
2316 if (name && name != &PL_padname_undef && !PadnameIsSTATE(name)
2317 && *PadnamePV(name) == '&')
2319 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2320 /* XXX 0afba48f added code here to check for a proto CV
2321 attached to the pad entry by magic. But shortly there-
2322 after 81df9f6f95 moved the magic to the pad name. The
2323 code here was never updated, so it wasn’t doing anything
2324 and got deleted when PADNAME became a distinct type. Is
2325 there any bug as a result? */
2326 CV * const innercv = MUTABLE_CV(curpad[ix]);
2327 if (CvOUTSIDE(innercv) == old_cv) {
2328 if (!CvWEAKOUTSIDE(innercv)) {
2329 SvREFCNT_dec(old_cv);
2330 SvREFCNT_inc_simple_void_NN(new_cv);
2332 CvOUTSIDE(innercv) = new_cv;
2335 else { /* format reference */
2336 SV * const rv = curpad[ix];
2338 if (!SvOK(rv)) continue;
2340 assert(SvWEAKREF(rv));
2341 innercv = (CV *)SvRV(rv);
2342 assert(!CvWEAKOUTSIDE(innercv));
2343 SvREFCNT_dec(CvOUTSIDE(innercv));
2344 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2351 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2353 Push a new pad frame onto the padlist, unless there's already a pad at
2354 this depth, in which case don't bother creating a new one. Then give
2355 the new pad an @_ in slot zero.
2361 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2363 PERL_ARGS_ASSERT_PAD_PUSH;
2365 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2366 PAD** const svp = PadlistARRAY(padlist);
2367 AV* const newpad = newAV();
2368 SV** const oldpad = AvARRAY(svp[depth-1]);
2369 I32 ix = AvFILLp((const AV *)svp[1]);
2370 const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2371 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2374 for ( ;ix > 0; ix--) {
2375 if (names_fill >= ix && PadnameLEN(names[ix])) {
2376 const char sigil = PadnamePV(names[ix])[0];
2377 if (PadnameOUTER(names[ix])
2378 || PadnameIsSTATE(names[ix])
2381 /* outer lexical or anon code */
2382 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2384 else { /* our own lexical */
2387 sv = MUTABLE_SV(newAV());
2388 else if (sigil == '%')
2389 sv = MUTABLE_SV(newHV());
2392 av_store(newpad, ix, sv);
2395 else if (PadnamePV(names[ix])) {
2396 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2399 /* save temporaries on recursion? */
2400 SV * const sv = newSV(0);
2401 av_store(newpad, ix, sv);
2406 av_store(newpad, 0, MUTABLE_SV(av));
2409 padlist_store(padlist, depth, newpad);
2413 #if defined(USE_ITHREADS)
2415 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2418 =for apidoc padlist_dup
2426 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2432 PERL_ARGS_ASSERT_PADLIST_DUP;
2434 cloneall = param->flags & CLONEf_COPY_STACKS;
2435 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2437 max = cloneall ? PadlistMAX(srcpad) : 1;
2439 Newx(dstpad, 1, PADLIST);
2440 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2441 PadlistMAX(dstpad) = max;
2442 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2444 PadlistARRAY(dstpad)[0] = (PAD *)
2445 padnamelist_dup(PadlistNAMES(srcpad), param);
2446 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2449 for (depth = 1; depth <= max; ++depth)
2450 PadlistARRAY(dstpad)[depth] =
2451 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2453 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2454 to build anything other than the first level of pads. */
2455 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2457 const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2458 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2459 SV **oldpad = AvARRAY(srcpad1);
2460 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2466 av_extend(pad1, ix);
2467 PadlistARRAY(dstpad)[1] = pad1;
2468 pad1a = AvARRAY(pad1);
2473 for ( ;ix > 0; ix--) {
2476 } else if (names_fill >= ix && names[ix] &&
2477 PadnameLEN(names[ix])) {
2478 const char sigil = PadnamePV(names[ix])[0];
2479 if (PadnameOUTER(names[ix])
2480 || PadnameIsSTATE(names[ix])
2483 /* outer lexical or anon code */
2484 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2486 else { /* our own lexical */
2487 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2488 /* This is a work around for how the current
2489 implementation of ?{ } blocks in regexps
2490 interacts with lexicals. */
2491 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2496 sv = MUTABLE_SV(newAV());
2497 else if (sigil == '%')
2498 sv = MUTABLE_SV(newHV());
2505 else if (( names_fill >= ix && names[ix]
2506 && PadnamePV(names[ix]) )) {
2507 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2510 /* save temporaries on recursion? */
2511 SV * const sv = newSV(0);
2514 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2515 FIXTHAT before merging this branch.
2516 (And I know how to) */
2517 if (SvPADTMP(oldpad[ix]))
2523 args = newAV(); /* Will be @_ */
2525 pad1a[0] = (SV *)args;
2533 #endif /* USE_ITHREADS */
2536 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2539 SSize_t const oldmax = PadlistMAX(padlist);
2541 PERL_ARGS_ASSERT_PADLIST_STORE;
2545 if (key > PadlistMAX(padlist)) {
2546 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2547 (SV ***)&PadlistARRAY(padlist),
2548 (SV ***)&PadlistARRAY(padlist));
2549 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2552 ary = PadlistARRAY(padlist);
2553 SvREFCNT_dec(ary[key]);
2559 =for apidoc newPADNAMELIST
2561 Creates a new pad name list. C<max> is the highest index for which space
2568 Perl_newPADNAMELIST(pTHX_ size_t max)
2571 Newx(pnl, 1, PADNAMELIST);
2572 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2573 PadnamelistMAX(pnl) = -1;
2574 PadnamelistREFCNT(pnl) = 1;
2575 PadnamelistMAXNAMED(pnl) = 0;
2576 pnl->xpadnl_max = max;
2581 =for apidoc padnamelist_store
2583 Stores the pad name (which may be null) at the given index, freeing any
2584 existing pad name in that slot.
2590 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2594 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2598 if (key > pnl->xpadnl_max)
2599 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2600 (SV ***)&PadnamelistARRAY(pnl),
2601 (SV ***)&PadnamelistARRAY(pnl));
2602 if (PadnamelistMAX(pnl) < key) {
2603 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2604 key-PadnamelistMAX(pnl), PADNAME *);
2605 PadnamelistMAX(pnl) = key;
2607 ary = PadnamelistARRAY(pnl);
2609 PadnameREFCNT_dec(ary[key]);
2615 =for apidoc padnamelist_fetch
2617 Fetches the pad name from the given index.
2623 Perl_padnamelist_fetch(pTHX_ PADNAMELIST *pnl, SSize_t key)
2625 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2628 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2632 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2634 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2635 if (!--PadnamelistREFCNT(pnl)) {
2636 while(PadnamelistMAX(pnl) >= 0)
2638 PADNAME * const pn =
2639 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2641 PadnameREFCNT_dec(pn);
2643 Safefree(PadnamelistARRAY(pnl));
2648 #if defined(USE_ITHREADS)
2651 =for apidoc padnamelist_dup
2653 Duplicates a pad name list.
2659 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2661 PADNAMELIST *dstpad;
2662 SSize_t max = PadnamelistMAX(srcpad);
2664 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2666 /* look for it in the table first */
2667 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2671 dstpad = newPADNAMELIST(max);
2672 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2673 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2674 PadnamelistMAX(dstpad) = max;
2676 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2677 for (; max >= 0; max--)
2678 if (PadnamelistARRAY(srcpad)[max]) {
2679 PadnamelistARRAY(dstpad)[max] =
2680 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2681 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2687 #endif /* USE_ITHREADS */
2690 =for apidoc newPADNAMEpvn
2692 Constructs and returns a new pad name. I<s> must be a UTF8 string. Do not
2693 use this for pad names that point to outer lexicals. See
2694 L</newPADNAMEouter>.
2700 Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len)
2702 struct padname_with_str *alloc;
2703 char *alloc2; /* for Newxz */
2705 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2707 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2709 alloc = (struct padname_with_str *)alloc2;
2710 pn = (PADNAME *)alloc;
2711 PadnameREFCNT(pn) = 1;
2712 PadnamePV(pn) = alloc->xpadn_str;
2713 Copy(s, PadnamePV(pn), len, char);
2714 *(PadnamePV(pn) + len) = '\0';
2715 PadnameLEN(pn) = len;
2720 =for apidoc newPADNAMEouter
2722 Constructs and returns a new pad name. Only use this function for names
2723 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) I<outer> is
2724 the outer pad name that this one mirrors. The returned pad name has the
2725 PADNAMEt_OUTER flag already set.
2731 Perl_newPADNAMEouter(pTHX_ PADNAME *outer)
2734 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2735 Newxz(pn, 1, PADNAME);
2736 PadnameREFCNT(pn) = 1;
2737 PadnamePV(pn) = PadnamePV(outer);
2738 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2739 another entry. The original pad name owns the buffer. */
2740 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2741 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2742 PadnameLEN(pn) = PadnameLEN(outer);
2747 Perl_padname_free(pTHX_ PADNAME *pn)
2749 PERL_ARGS_ASSERT_PADNAME_FREE;
2750 if (!--PadnameREFCNT(pn)) {
2751 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2752 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2755 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2756 SvREFCNT_dec(PadnameOURSTASH(pn));
2757 if (PadnameOUTER(pn))
2758 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2763 #if defined(USE_ITHREADS)
2766 =for apidoc padname_dup
2768 Duplicates a pad name.
2774 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2778 PERL_ARGS_ASSERT_PADNAME_DUP;
2780 /* look for it in the table first */
2781 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2785 if (!PadnamePV(src)) {
2786 dst = &PL_padname_undef;
2787 ptr_table_store(PL_ptr_table, src, dst);
2791 dst = PadnameOUTER(src)
2792 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2793 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2794 ptr_table_store(PL_ptr_table, src, dst);
2795 PadnameLEN(dst) = PadnameLEN(src);
2796 PadnameFLAGS(dst) = PadnameFLAGS(src);
2797 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2798 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2799 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2801 dst->xpadn_low = src->xpadn_low;
2802 dst->xpadn_high = src->xpadn_high;
2803 dst->xpadn_gen = src->xpadn_gen;
2807 #endif /* USE_ITHREADS */
2811 * c-indentation-style: bsd
2813 * indent-tabs-mode: nil
2816 * ex: set ts=8 sts=4 sw=4 et: