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 don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
45 The PADLIST has a C array where pads are stored.
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals. The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it. See L</PadlistNAMES>.
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV. The 0th slot of a frame AV is an
56 AV which is @_. Other entries are storage for variables and op targets.
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
60 "names", while slots for constants have &PL_sv_no "names" (see
61 pad_alloc()). That &PL_sv_no is used is an implementation detail subject
62 to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
64 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
65 The rest are op targets/GVs/constants which are statically allocated
66 or resolved at compile time. These don't have names by which they
67 can be looked up from Perl code at run time through eval"" the way
68 my/our variables can be. Since they can't be looked up by "name"
69 but only by their index allocated at compile time (which is usually
70 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
72 The SVs in the names AV have their PV being the name of the variable.
73 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
74 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
75 _HIGH). During compilation, these fields may hold the special value
76 PERL_PADSEQ_INTRO to indicate various stages:
78 COP_SEQ_RANGE_LOW _HIGH
79 ----------------- -----
80 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
81 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
82 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
84 For typed lexicals name SV is SVt_PVMG and SvSTASH
85 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
86 SvOURSTASH slot pointing at the stash of the associated global (so that
87 duplicate C<our> declarations in the same package can be detected). SvUVX is
88 sometimes hijacked to store the generation number during compilation.
90 If PADNAME_OUTER (SvFAKE) is set on the
91 name SV, then that slot in the frame AV is
92 a REFCNT'ed reference to a lexical from "outside". In this case,
93 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
94 in scope throughout. Instead xhigh stores some flags containing info about
95 the real lexical (is it declared in an anon, and is it capable of being
96 instantiated multiple times?), and for fake ANONs, xlow contains the index
97 within the parent's pad where the lexical's value is stored, to make
100 If the 'name' is '&' the corresponding entry in the PAD
101 is a CV representing a possible closure.
102 (PADNAME_OUTER and name of '&' is not a
103 meaningful combination currently but could
104 become so if C<my sub foo {}> is implemented.)
106 Note that formats are treated as anon subs, and are cloned each time
107 write is called (if necessary).
109 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
110 and set on scope exit. This allows the
111 'Variable $x is not available' warning
112 to be generated in evals, such as
114 { my $x = 1; sub f { eval '$x'} } f();
116 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
118 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
120 During compilation, this points to the array containing the names part
121 of the pad for the currently-compiling code.
123 =for apidoc AmxU|PAD *|PL_comppad
125 During compilation, this points to the array containing the values
126 part of the pad for the currently-compiling code. (At runtime a CV may
127 have many such value arrays; at compile time just one is constructed.)
128 At runtime, this points to the array containing the currently-relevant
129 values for the pad for the currently-executing code.
131 =for apidoc AmxU|SV **|PL_curpad
133 Points directly to the body of the L</PL_comppad> array.
134 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
141 #define PERL_IN_PAD_C
143 #include "keywords.h"
145 #define COP_SEQ_RANGE_LOW_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
150 #define PARENT_PAD_INDEX_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
152 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
153 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
156 This is basically sv_eq_flags() in sv.c, but we avoid the magic
161 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
162 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
163 const char *pv1 = SvPVX_const(sv);
164 STRLEN cur1 = SvCUR(sv);
165 const char *pv2 = pv;
170 svrecode = newSVpvn(pv2, cur2);
171 sv_recode_to_utf8(svrecode, PL_encoding);
172 pv2 = SvPV_const(svrecode, cur2);
175 svrecode = newSVpvn(pv1, cur1);
176 sv_recode_to_utf8(svrecode, PL_encoding);
177 pv1 = SvPV_const(svrecode, cur1);
179 SvREFCNT_dec_NN(svrecode);
181 if (flags & SVf_UTF8)
182 return (bytes_cmp_utf8(
183 (const U8*)pv1, cur1,
184 (const U8*)pv2, cur2) == 0);
186 return (bytes_cmp_utf8(
187 (const U8*)pv2, cur2,
188 (const U8*)pv1, cur1) == 0);
191 return ((SvPVX_const(sv) == pv)
192 || memEQ(SvPVX_const(sv), pv, pvlen));
197 =for apidoc Am|PADLIST *|pad_new|int flags
199 Create a new padlist, updating the global variables for the
200 currently-compiling padlist to point to the new padlist. The following
201 flags can be OR'ed together:
203 padnew_CLONE this pad is for a cloned CV
204 padnew_SAVE save old globals on the save stack
205 padnew_SAVESUB also save extra stuff for start of sub
211 Perl_pad_new(pTHX_ int flags)
218 ASSERT_CURPAD_LEGAL("pad_new");
220 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
221 * vars (based on flags) rather than storing vals + addresses for
222 * each individually. Also see pad_block_start.
223 * XXX DAPM Try to see whether all these conditionals are required
226 /* save existing state, ... */
228 if (flags & padnew_SAVE) {
230 if (! (flags & padnew_CLONE)) {
231 SAVESPTR(PL_comppad_name);
233 SAVEI32(PL_comppad_name_fill);
234 SAVEI32(PL_min_intro_pending);
235 SAVEI32(PL_max_intro_pending);
236 SAVEBOOL(PL_cv_has_eval);
237 if (flags & padnew_SAVESUB) {
238 SAVEBOOL(PL_pad_reset_pending);
242 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
243 * saved - check at some pt that this is okay */
245 /* ... create new pad ... */
247 Newxz(padlist, 1, PADLIST);
250 if (flags & padnew_CLONE) {
251 /* XXX DAPM I dont know why cv_clone needs it
252 * doing differently yet - perhaps this separate branch can be
253 * dispensed with eventually ???
256 AV * const a0 = newAV(); /* will be @_ */
257 av_store(pad, 0, MUTABLE_SV(a0));
260 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
263 av_store(pad, 0, NULL);
265 AvPAD_NAMELIST_on(padname);
266 av_store(padname, 0, &PL_sv_undef);
269 /* Most subroutines never recurse, hence only need 2 entries in the padlist
270 array - names, and depth=1. The default for av_store() is to allocate
271 0..3, and even an explicit call to av_extend() with <3 will be rounded
272 up, so we inline the allocation of the array here. */
274 PadlistMAX(padlist) = 1;
275 PadlistARRAY(padlist) = ary;
279 /* ... then update state variables */
282 PL_curpad = AvARRAY(pad);
284 if (! (flags & padnew_CLONE)) {
285 PL_comppad_name = padname;
286 PL_comppad_name_fill = 0;
287 PL_min_intro_pending = 0;
292 DEBUG_X(PerlIO_printf(Perl_debug_log,
293 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
294 " name=0x%"UVxf" flags=0x%"UVxf"\n",
295 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
296 PTR2UV(padname), (UV)flags
300 return (PADLIST*)padlist;
305 =head1 Embedding Functions
309 Clear out all the active components of a CV. This can happen either
310 by an explicit C<undef &foo>, or by the reference count going to zero.
311 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
312 children can still follow the full lexical scope chain.
318 Perl_cv_undef(pTHX_ CV *cv)
321 const PADLIST *padlist = CvPADLIST(cv);
322 bool const slabbed = !!CvSLABBED(cv);
324 PERL_ARGS_ASSERT_CV_UNDEF;
326 DEBUG_X(PerlIO_printf(Perl_debug_log,
327 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
328 PTR2UV(cv), PTR2UV(PL_comppad))
331 if (CvFILE(cv) && CvDYNFILE(cv)) {
332 Safefree(CvFILE(cv));
337 if (!CvISXSUB(cv) && CvROOT(cv)) {
338 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
339 Perl_croak(aTHX_ "Can't undef active subroutine");
342 PAD_SAVE_SETNULLPAD();
344 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
350 else if (slabbed && CvSTART(cv)) {
352 PAD_SAVE_SETNULLPAD();
354 /* discard any leaked ops */
356 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
357 opslab_force_free((OPSLAB *)CvSTART(cv));
363 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
365 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
366 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
367 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
368 else CvGV_set(cv, NULL);
370 /* This statement and the subsequence if block was pad_undef(). */
371 pad_peg("pad_undef");
376 /* Free the padlist associated with a CV.
377 If parts of it happen to be current, we null the relevant PL_*pad*
378 global vars so that we don't have any dangling references left.
379 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
380 subs to the outer of this cv. */
382 DEBUG_X(PerlIO_printf(Perl_debug_log,
383 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
384 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
387 /* detach any '&' anon children in the pad; if afterwards they
388 * are still live, fix up their CvOUTSIDEs to point to our outside,
390 /* XXX DAPM for efficiency, we should only do this if we know we have
391 * children, or integrate this loop with general cleanup */
393 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
394 CV * const outercv = CvOUTSIDE(cv);
395 const U32 seq = CvOUTSIDE_SEQ(cv);
396 PAD * const comppad_name = PadlistARRAY(padlist)[0];
397 SV ** const namepad = AvARRAY(comppad_name);
398 PAD * const comppad = PadlistARRAY(padlist)[1];
399 SV ** const curpad = AvARRAY(comppad);
400 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
401 SV * const namesv = namepad[ix];
402 if (namesv && namesv != &PL_sv_undef
403 && *SvPVX_const(namesv) == '&')
405 CV * const innercv = MUTABLE_CV(curpad[ix]);
406 U32 inner_rc = SvREFCNT(innercv);
408 assert(SvTYPE(innercv) != SVt_PVFM);
410 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
412 SvREFCNT_dec_NN(innercv);
416 /* in use, not just a prototype */
417 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
418 assert(CvWEAKOUTSIDE(innercv));
419 /* don't relink to grandfather if he's being freed */
420 if (outercv && SvREFCNT(outercv)) {
421 CvWEAKOUTSIDE_off(innercv);
422 CvOUTSIDE(innercv) = outercv;
423 CvOUTSIDE_SEQ(innercv) = seq;
424 SvREFCNT_inc_simple_void_NN(outercv);
427 CvOUTSIDE(innercv) = NULL;
434 ix = PadlistMAX(padlist);
436 PAD * const sv = PadlistARRAY(padlist)[ix--];
438 if (sv == PL_comppad) {
446 PAD * const sv = PadlistARRAY(padlist)[0];
447 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
448 PL_comppad_name = NULL;
451 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
453 CvPADLIST(cv) = NULL;
457 /* remove CvOUTSIDE unless this is an undef rather than a free */
458 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
459 if (!CvWEAKOUTSIDE(cv))
460 SvREFCNT_dec(CvOUTSIDE(cv));
461 CvOUTSIDE(cv) = NULL;
464 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
467 if (CvISXSUB(cv) && CvXSUB(cv)) {
470 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
471 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
472 * to choose an error message */
473 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
477 =for apidoc cv_forget_slab
479 When a CV has a reference count on its slab (CvSLABBED), it is responsible
480 for making sure it is freed. (Hence, no two CVs should ever have a
481 reference count on the same slab.) The CV only needs to reference the slab
482 during compilation. Once it is compiled and CvROOT attached, it has
483 finished its job, so it can forget the slab.
489 Perl_cv_forget_slab(pTHX_ CV *cv)
491 const bool slabbed = !!CvSLABBED(cv);
494 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
496 if (!slabbed) return;
500 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
501 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
503 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
507 #ifdef PERL_DEBUG_READONLY_OPS
508 const size_t refcnt = slab->opslab_refcnt;
510 OpslabREFCNT_dec(slab);
511 #ifdef PERL_DEBUG_READONLY_OPS
512 if (refcnt > 1) Slab_to_ro(slab);
518 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
520 Allocates a place in the currently-compiling
521 pad (via L<perlapi/pad_alloc>) and
522 then stores a name for that entry. I<namesv> is adopted and becomes the
523 name entry; it must already contain the name string and be sufficiently
524 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
525 added to I<namesv>. None of the other
526 processing of L<perlapi/pad_add_name_pvn>
527 is done. Returns the offset of the allocated pad slot.
533 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
536 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
538 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
540 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
543 assert(SvTYPE(namesv) == SVt_PVMG);
544 SvPAD_TYPED_on(namesv);
545 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
548 SvPAD_OUR_on(namesv);
549 SvOURSTASH_set(namesv, ourstash);
550 SvREFCNT_inc_simple_void_NN(ourstash);
552 else if (flags & padadd_STATE) {
553 SvPAD_STATE_on(namesv);
556 av_store(PL_comppad_name, offset, namesv);
557 PadnamelistMAXNAMED(PL_comppad_name) = offset;
562 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
564 Allocates a place in the currently-compiling pad for a named lexical
565 variable. Stores the name and other metadata in the name part of the
566 pad, and makes preparations to manage the variable's lexical scoping.
567 Returns the offset of the allocated pad slot.
569 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
570 If I<typestash> is non-null, the name is for a typed lexical, and this
571 identifies the type. If I<ourstash> is non-null, it's a lexical reference
572 to a package variable, and this identifies the package. The following
573 flags can be OR'ed together:
575 padadd_OUR redundantly specifies if it's a package var
576 padadd_STATE variable will retain value persistently
577 padadd_NO_DUP_CHECK skip check for lexical shadowing
583 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
584 U32 flags, HV *typestash, HV *ourstash)
591 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
593 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
594 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
597 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
599 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
600 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
603 sv_setpvn(namesv, namepv, namelen);
606 flags |= padadd_UTF8_NAME;
610 flags &= ~padadd_UTF8_NAME;
612 if ((flags & padadd_NO_DUP_CHECK) == 0) {
614 SAVEFREESV(namesv); /* in case of fatal warnings */
615 /* check for duplicate declaration */
616 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
617 SvREFCNT_inc_simple_void_NN(namesv);
621 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
623 /* not yet introduced */
624 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
625 COP_SEQ_RANGE_HIGH_set(namesv, 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, SvPVX(namesv),
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 = SvPV(name, namelen);
682 flags |= padadd_UTF8_NAME;
683 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
687 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
689 Allocates a place in the currently-compiling pad,
690 returning the offset of the allocated pad slot.
691 No name is initially attached to the pad slot.
692 I<tmptype> is a set of flags indicating the kind of pad entry required,
693 which will be set in the value SV for the allocated pad entry:
695 SVs_PADMY named lexical variable ("my", "our", "state")
696 SVs_PADTMP unnamed temporary store
697 SVf_READONLY constant shared between recursion levels
699 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
700 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
701 does not cause the SV in the pad slot to be marked read-only, but simply
702 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
703 least should be treated as such.
705 I<optype> should be an opcode indicating the type of operation that the
706 pad entry is to support. This doesn't affect operational semantics,
707 but is used for debugging.
712 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
713 * or at least rationalise ??? */
716 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
722 PERL_UNUSED_ARG(optype);
723 ASSERT_CURPAD_ACTIVE("pad_alloc");
725 if (AvARRAY(PL_comppad) != PL_curpad)
726 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
727 AvARRAY(PL_comppad), PL_curpad);
728 if (PL_pad_reset_pending)
730 if (tmptype & SVs_PADMY) {
731 /* For a my, simply push a null SV onto the end of PL_comppad. */
732 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
733 retval = AvFILLp(PL_comppad);
736 /* For a tmp, scan the pad from PL_padix upwards
737 * for a slot which has no name and no active value.
739 SV * const * const names = AvARRAY(PL_comppad_name);
740 const SSize_t names_fill = AvFILLp(PL_comppad_name);
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.
748 if (++PL_padix <= names_fill &&
749 (sv = names[PL_padix]) && sv != &PL_sv_undef)
751 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
752 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
756 if (tmptype & SVf_READONLY) {
757 av_store(PL_comppad_name, PL_padix, &PL_sv_no);
758 tmptype &= ~SVf_READONLY;
759 tmptype |= SVs_PADTMP;
763 SvFLAGS(sv) |= tmptype;
764 PL_curpad = AvARRAY(PL_comppad);
766 DEBUG_X(PerlIO_printf(Perl_debug_log,
767 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
768 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
769 PL_op_name[optype]));
770 #ifdef DEBUG_LEAKING_SCALARS
771 sv->sv_debug_optype = optype;
772 sv->sv_debug_inpad = 1;
774 return (PADOFFSET)retval;
778 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
780 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
781 for an anonymous function that is lexically scoped inside the
782 currently-compiling function.
783 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
784 to the outer scope is weakened to avoid a reference loop.
786 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
788 I<optype> should be an opcode indicating the type of operation that the
789 pad entry is to support. This doesn't affect operational semantics,
790 but is used for debugging.
796 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
800 SV* const name = newSV_type(SVt_PVNV);
802 PERL_ARGS_ASSERT_PAD_ADD_ANON;
805 sv_setpvs(name, "&");
806 /* These two aren't used; just make sure they're not equal to
807 * PERL_PADSEQ_INTRO */
808 COP_SEQ_RANGE_LOW_set(name, 0);
809 COP_SEQ_RANGE_HIGH_set(name, 0);
810 ix = pad_alloc(optype, SVs_PADMY);
811 av_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);
821 SvPADMY_on((SV*)func);
823 /* to avoid ref loops, we never have parent + child referencing each
824 * other simultaneously */
825 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
826 assert(!CvWEAKOUTSIDE(func));
827 CvWEAKOUTSIDE_on(func);
828 SvREFCNT_dec_NN(CvOUTSIDE(func));
834 =for apidoc pad_check_dup
836 Check for duplicate declarations: report any of:
838 * a my in the current scope with the same name;
839 * an our (anywhere in the pad) with the same name and the
840 same stash as C<ourstash>
842 C<is_our> indicates that the name to check is an 'our' declaration.
848 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
853 const U32 is_our = flags & padadd_OUR;
855 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
857 ASSERT_CURPAD_ACTIVE("pad_check_dup");
859 assert((flags & ~padadd_OUR) == 0);
861 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
862 return; /* nothing to check */
864 svp = AvARRAY(PL_comppad_name);
865 top = AvFILLp(PL_comppad_name);
866 /* check the current scope */
867 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
869 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
870 SV * const sv = svp[off];
874 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
875 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
878 if (is_our && (SvPAD_OUR(sv)))
879 break; /* "our" masking "our" */
880 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
881 Perl_warner(aTHX_ packWARN(WARN_MISC),
882 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
883 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
884 *SvPVX(sv) == '&' ? "subroutine" : "variable",
886 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
887 ? "scope" : "statement"));
892 /* check the rest of the pad */
895 SV * const sv = svp[off];
899 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
900 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
901 && SvOURSTASH(sv) == ourstash
904 Perl_warner(aTHX_ packWARN(WARN_MISC),
905 "\"our\" variable %"SVf" redeclared", SVfARG(sv));
906 if ((I32)off <= PL_comppad_name_floor)
907 Perl_warner(aTHX_ packWARN(WARN_MISC),
908 "\t(Did you mean \"local\" instead of \"our\"?)\n");
918 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
920 Given the name of a lexical variable, find its position in the
921 currently-compiling pad.
922 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
923 I<flags> is reserved and must be zero.
924 If it is not in the current pad but appears in the pad of any lexically
925 enclosing scope, then a pseudo-entry for it is added in the current pad.
926 Returns the offset in the current pad,
927 or C<NOT_IN_PAD> if no such lexical is in scope.
933 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
942 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
944 pad_peg("pad_findmy_pvn");
946 if (flags & ~padadd_UTF8_NAME)
947 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
950 if (flags & padadd_UTF8_NAME) {
952 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
955 flags |= padadd_UTF8_NAME;
957 flags &= ~padadd_UTF8_NAME;
960 offset = pad_findlex(namepv, namelen, flags,
961 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
962 if ((PADOFFSET)offset != NOT_IN_PAD)
965 /* look for an our that's being introduced; this allows
966 * our $foo = 0 unless defined $foo;
967 * to not give a warning. (Yes, this is a hack) */
969 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
970 name_svp = AvARRAY(nameav);
971 for (offset = AvFILLp(nameav); offset > 0; offset--) {
972 const SV * const namesv = name_svp[offset];
973 if (namesv && PadnameLEN(namesv) == namelen
975 && (SvPAD_OUR(namesv))
976 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
977 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
978 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
986 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
988 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
989 instead of a string/length pair.
995 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
997 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
998 return pad_findmy_pvn(name, strlen(name), flags);
1002 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1004 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1005 of an SV instead of a string/length pair.
1011 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1015 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1016 namepv = SvPV(name, namelen);
1018 flags |= padadd_UTF8_NAME;
1019 return pad_findmy_pvn(namepv, namelen, flags);
1023 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1025 Find the position of the lexical C<$_> in the pad of the
1026 currently-executing function. Returns the offset in the current pad,
1027 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1028 the global one should be used instead).
1029 L</find_rundefsv> is likely to be more convenient.
1035 Perl_find_rundefsvoffset(pTHX)
1040 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1041 NULL, &out_sv, &out_flags);
1045 =for apidoc Am|SV *|find_rundefsv
1047 Find and return the variable that is named C<$_> in the lexical scope
1048 of the currently-executing function. This may be a lexical C<$_>,
1049 or will otherwise be the global one.
1055 Perl_find_rundefsv(pTHX)
1061 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1062 NULL, &namesv, &flags);
1064 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1071 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1077 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1079 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1080 NULL, &namesv, &flags);
1082 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1085 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1089 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1091 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1092 in the inner pads if it's found in an outer one.
1094 Returns the offset in the bottom pad of the lex or the fake lex.
1095 cv is the CV in which to start the search, and seq is the current cop_seq
1096 to match against. If warn is true, print appropriate warnings. The out_*
1097 vars return values, and so are pointers to where the returned values
1098 should be stored. out_capture, if non-null, requests that the innermost
1099 instance of the lexical is captured; out_name_sv is set to the innermost
1100 matched namesv or fake namesv; out_flags returns the flags normally
1101 associated with the IVX field of a fake namesv.
1103 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1104 then comes back down, adding fake entries
1105 as it goes. It has to be this way
1106 because fake namesvs in anon protoypes have to store in xlow the index into
1112 /* the CV has finished being compiled. This is not a sufficient test for
1113 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1114 #define CvCOMPILED(cv) CvROOT(cv)
1116 /* the CV does late binding of its lexicals */
1117 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1120 S_unavailable(pTHX_ SV *namesv)
1122 /* diag_listed_as: Variable "%s" is not available */
1123 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1124 "%se \"%"SVf"\" is not available",
1125 *SvPVX_const(namesv) == '&'
1132 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1133 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1136 I32 offset, new_offset;
1139 const PADLIST * const padlist = CvPADLIST(cv);
1140 const bool staleok = !!(flags & padadd_STALEOK);
1142 PERL_ARGS_ASSERT_PAD_FINDLEX;
1144 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1145 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1147 flags &= ~ padadd_STALEOK; /* one-shot flag */
1151 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1152 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1153 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1154 out_capture ? " capturing" : "" ));
1156 /* first, search this pad */
1158 if (padlist) { /* not an undef CV */
1159 I32 fake_offset = 0;
1160 const AV * const nameav = PadlistARRAY(padlist)[0];
1161 SV * const * const name_svp = AvARRAY(nameav);
1163 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1164 const SV * const namesv = name_svp[offset];
1165 if (namesv && PadnameLEN(namesv) == namelen
1166 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1167 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1169 if (SvFAKE(namesv)) {
1170 fake_offset = offset; /* in case we don't find a real one */
1173 /* is seq within the range _LOW to _HIGH ?
1174 * This is complicated by the fact that PL_cop_seqmax
1175 * may have wrapped around at some point */
1176 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1177 continue; /* not yet introduced */
1179 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1180 /* in compiling scope */
1182 (seq > COP_SEQ_RANGE_LOW(namesv))
1183 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1184 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1189 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1191 ( seq > COP_SEQ_RANGE_LOW(namesv)
1192 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1194 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1195 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1201 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1202 if (offset > 0) { /* not fake */
1204 *out_name_sv = name_svp[offset]; /* return the namesv */
1206 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1207 * instances. For now, we just test !CvUNIQUE(cv), but
1208 * ideally, we should detect my's declared within loops
1209 * etc - this would allow a wider range of 'not stayed
1210 * shared' warnings. We also treated already-compiled
1211 * lexes as not multi as viewed from evals. */
1213 *out_flags = CvANON(cv) ?
1215 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1216 ? PAD_FAKELEX_MULTI : 0;
1218 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1219 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1220 PTR2UV(cv), (long)offset,
1221 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1222 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1224 else { /* fake match */
1225 offset = fake_offset;
1226 *out_name_sv = name_svp[offset]; /* return the namesv */
1227 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1228 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1229 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1230 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1231 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1235 /* return the lex? */
1240 if (SvPAD_OUR(*out_name_sv)) {
1241 *out_capture = NULL;
1245 /* trying to capture from an anon prototype? */
1247 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1248 : *out_flags & PAD_FAKELEX_ANON)
1252 newSVpvn_flags(namepv, namelen,
1254 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1256 *out_capture = NULL;
1262 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1263 && !SvPAD_STATE(name_svp[offset])
1264 && warn && ckWARN(WARN_CLOSURE)) {
1266 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1267 "Variable \"%"SVf"\" will not stay shared",
1268 SVfARG(newSVpvn_flags(namepv, namelen,
1270 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1273 if (fake_offset && CvANON(cv)
1274 && CvCLONE(cv) &&!CvCLONED(cv))
1277 /* not yet caught - look further up */
1278 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1279 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1282 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1284 newwarn, out_capture, out_name_sv, out_flags);
1289 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1290 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1291 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1292 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1293 PTR2UV(cv), PTR2UV(*out_capture)));
1295 if (SvPADSTALE(*out_capture)
1296 && (!CvDEPTH(cv) || !staleok)
1297 && !SvPAD_STATE(name_svp[offset]))
1300 newSVpvn_flags(namepv, namelen,
1302 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1303 *out_capture = NULL;
1306 if (!*out_capture) {
1307 if (namelen != 0 && *namepv == '@')
1308 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1309 else if (namelen != 0 && *namepv == '%')
1310 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1311 else if (namelen != 0 && *namepv == '&')
1312 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1314 *out_capture = sv_newmortal();
1322 /* it's not in this pad - try above */
1327 /* out_capture non-null means caller wants us to capture lex; in
1328 * addition we capture ourselves unless it's an ANON/format */
1329 new_capturep = out_capture ? out_capture :
1330 CvLATE(cv) ? NULL : &new_capture;
1332 offset = pad_findlex(namepv, namelen,
1333 flags | padadd_STALEOK*(new_capturep == &new_capture),
1334 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1335 new_capturep, out_name_sv, out_flags);
1336 if ((PADOFFSET)offset == NOT_IN_PAD)
1339 /* found in an outer CV. Add appropriate fake entry to this pad */
1341 /* don't add new fake entries (via eval) to CVs that we have already
1342 * finished compiling, or to undef CVs */
1343 if (CvCOMPILED(cv) || !padlist)
1344 return 0; /* this dummy (and invalid) value isnt used by the caller */
1347 /* This relies on sv_setsv_flags() upgrading the destination to the same
1348 type as the source, independent of the flags set, and on it being
1349 "good" and only copying flag bits and pointers that it understands.
1351 SV *new_namesv = newSVsv(*out_name_sv);
1352 AV * const ocomppad_name = PL_comppad_name;
1353 PAD * const ocomppad = PL_comppad;
1354 PL_comppad_name = PadlistARRAY(padlist)[0];
1355 PL_comppad = PadlistARRAY(padlist)[1];
1356 PL_curpad = AvARRAY(PL_comppad);
1359 = pad_alloc_name(new_namesv,
1360 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1361 SvPAD_TYPED(*out_name_sv)
1362 ? SvSTASH(*out_name_sv) : NULL,
1363 SvOURSTASH(*out_name_sv)
1366 SvFAKE_on(new_namesv);
1367 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1368 "Pad addname: %ld \"%.*s\" FAKE\n",
1370 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1371 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1373 PARENT_PAD_INDEX_set(new_namesv, 0);
1374 if (SvPAD_OUR(new_namesv)) {
1375 NOOP; /* do nothing */
1377 else if (CvLATE(cv)) {
1378 /* delayed creation - just note the offset within parent pad */
1379 PARENT_PAD_INDEX_set(new_namesv, offset);
1383 /* immediate creation - capture outer value right now */
1384 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1385 /* But also note the offset, as newMYSUB needs it */
1386 PARENT_PAD_INDEX_set(new_namesv, offset);
1387 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1388 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1389 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1391 *out_name_sv = new_namesv;
1392 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1394 PL_comppad_name = ocomppad_name;
1395 PL_comppad = ocomppad;
1396 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1404 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1406 Get the value at offset I<po> in the current (compiling or executing) pad.
1407 Use macro PAD_SV instead of calling this function directly.
1413 Perl_pad_sv(pTHX_ PADOFFSET po)
1416 ASSERT_CURPAD_ACTIVE("pad_sv");
1419 Perl_croak(aTHX_ "panic: pad_sv po");
1420 DEBUG_X(PerlIO_printf(Perl_debug_log,
1421 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1422 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1424 return PL_curpad[po];
1428 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1430 Set the value at offset I<po> in the current (compiling or executing) pad.
1431 Use the macro PAD_SETSV() rather than calling this function directly.
1437 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1441 PERL_ARGS_ASSERT_PAD_SETSV;
1443 ASSERT_CURPAD_ACTIVE("pad_setsv");
1445 DEBUG_X(PerlIO_printf(Perl_debug_log,
1446 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1447 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1452 #endif /* DEBUGGING */
1455 =for apidoc m|void|pad_block_start|int full
1457 Update the pad compilation state variables on entry to a new block.
1462 /* XXX DAPM perhaps:
1463 * - integrate this in general state-saving routine ???
1464 * - combine with the state-saving going on in pad_new ???
1465 * - introduce a new SAVE type that does all this in one go ?
1469 Perl_pad_block_start(pTHX_ int full)
1472 ASSERT_CURPAD_ACTIVE("pad_block_start");
1473 SAVEI32(PL_comppad_name_floor);
1474 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1476 PL_comppad_name_fill = PL_comppad_name_floor;
1477 if (PL_comppad_name_floor < 0)
1478 PL_comppad_name_floor = 0;
1479 SAVEI32(PL_min_intro_pending);
1480 SAVEI32(PL_max_intro_pending);
1481 PL_min_intro_pending = 0;
1482 SAVEI32(PL_comppad_name_fill);
1483 SAVEI32(PL_padix_floor);
1484 PL_padix_floor = PL_padix;
1485 PL_pad_reset_pending = FALSE;
1489 =for apidoc m|U32|intro_my
1491 "Introduce" my variables to visible status. This is called during parsing
1492 at the end of each statement to make lexical variables visible to
1493 subsequent statements.
1506 ASSERT_CURPAD_ACTIVE("intro_my");
1507 if (! PL_min_intro_pending)
1508 return PL_cop_seqmax;
1510 svp = AvARRAY(PL_comppad_name);
1511 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1512 SV * const sv = svp[i];
1514 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1515 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1517 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1518 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1519 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1520 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1521 (long)i, SvPVX_const(sv),
1522 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1523 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1527 seq = PL_cop_seqmax;
1529 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1531 PL_min_intro_pending = 0;
1532 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1533 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1534 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1540 =for apidoc m|void|pad_leavemy
1542 Cleanup at end of scope during compilation: set the max seq number for
1543 lexicals in this scope and warn of any lexicals that never got introduced.
1549 Perl_pad_leavemy(pTHX)
1554 SV * const * const svp = AvARRAY(PL_comppad_name);
1556 PL_pad_reset_pending = FALSE;
1558 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1559 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1560 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1561 const SV * const sv = svp[off];
1562 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1563 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1564 "%"SVf" never introduced",
1568 /* "Deintroduce" my variables that are leaving with this scope. */
1569 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1570 SV * const sv = svp[off];
1571 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1572 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1574 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1575 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1576 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1577 (long)off, SvPVX_const(sv),
1578 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1579 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1581 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1582 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1583 OP *kid = newOP(OP_INTROCV, 0);
1585 o = op_prepend_elem(OP_LINESEQ, kid, o);
1590 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1592 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1593 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1598 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1600 Abandon the tmp in the current pad at offset po and replace with a
1607 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1610 ASSERT_CURPAD_LEGAL("pad_swipe");
1613 if (AvARRAY(PL_comppad) != PL_curpad)
1614 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1615 AvARRAY(PL_comppad), PL_curpad);
1616 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1617 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1618 (long)po, (long)AvFILLp(PL_comppad));
1620 DEBUG_X(PerlIO_printf(Perl_debug_log,
1621 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1622 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1625 SvREFCNT_dec(PL_curpad[po]);
1628 /* if pad tmps aren't shared between ops, then there's no need to
1629 * create a new tmp when an existing op is freed */
1630 #ifdef USE_BROKEN_PAD_RESET
1631 PL_curpad[po] = newSV(0);
1632 SvPADTMP_on(PL_curpad[po]);
1634 PL_curpad[po] = NULL;
1636 if (PadnamelistMAX(PL_comppad_name) != -1
1637 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1638 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1639 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1641 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1643 if ((I32)po < PL_padix)
1648 =for apidoc m|void|pad_reset
1650 Mark all the current temporaries for reuse
1655 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1656 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1657 * on the stack by OPs that use them, there are several ways to get an alias
1658 * to a shared TARG. Such an alias will change randomly and unpredictably.
1659 * We avoid doing this until we can think of a Better Way.
1665 #ifdef USE_BROKEN_PAD_RESET
1666 if (AvARRAY(PL_comppad) != PL_curpad)
1667 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1668 AvARRAY(PL_comppad), PL_curpad);
1670 DEBUG_X(PerlIO_printf(Perl_debug_log,
1671 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1672 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1673 (long)PL_padix, (long)PL_padix_floor
1677 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1679 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1680 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1681 SvPADTMP_off(PL_curpad[po]);
1683 PL_padix = PL_padix_floor;
1686 PL_pad_reset_pending = FALSE;
1690 =for apidoc Amx|void|pad_tidy|padtidy_type type
1692 Tidy up a pad at the end of compilation of the code to which it belongs.
1693 Jobs performed here are: remove most stuff from the pads of anonsub
1694 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1695 the kind of subroutine:
1697 padtidy_SUB ordinary subroutine
1698 padtidy_SUBCLONE prototype for lexical closure
1699 padtidy_FORMAT format
1704 /* XXX DAPM surely most of this stuff should be done properly
1705 * at the right time beforehand, rather than going around afterwards
1706 * cleaning up our mistakes ???
1710 Perl_pad_tidy(pTHX_ padtidy_type type)
1714 ASSERT_CURPAD_ACTIVE("pad_tidy");
1716 /* If this CV has had any 'eval-capable' ops planted in it:
1717 * i.e. it contains any of:
1721 * * use re 'eval'; /$var/
1724 * Then any anon prototypes in the chain of CVs should be marked as
1725 * cloneable, so that for example the eval's CV in
1729 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1730 * potentially have an eval executed within it.
1733 if (PL_cv_has_eval || PL_perldb) {
1735 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1736 if (cv != PL_compcv && CvCOMPILED(cv))
1737 break; /* no need to mark already-compiled code */
1739 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1740 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1747 /* extend namepad to match curpad */
1748 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1749 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1751 if (type == padtidy_SUBCLONE) {
1752 SV ** const namep = AvARRAY(PL_comppad_name);
1755 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1757 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1760 * The only things that a clonable function needs in its
1761 * pad are anonymous subs, constants and GVs.
1762 * The rest are created anew during cloning.
1764 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1765 || IS_PADGV(PL_curpad[ix]))
1768 if (!(PadnamePV(namesv) &&
1769 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1771 SvREFCNT_dec(PL_curpad[ix]);
1772 PL_curpad[ix] = NULL;
1776 else if (type == padtidy_SUB) {
1777 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1778 AV * const av = newAV(); /* Will be @_ */
1779 av_store(PL_comppad, 0, MUTABLE_SV(av));
1783 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1784 SV ** const namep = AvARRAY(PL_comppad_name);
1786 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1787 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1788 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1789 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1791 if (!SvPADMY(PL_curpad[ix])) {
1792 SvPADTMP_on(PL_curpad[ix]);
1793 } else if (!SvFAKE(namep[ix])) {
1794 /* This is a work around for how the current implementation of
1795 ?{ } blocks in regexps interacts with lexicals.
1797 One of our lexicals.
1798 Can't do this on all lexicals, otherwise sub baz() won't
1807 because completion of compiling &bar calling pad_tidy()
1808 would cause (top level) $foo to be marked as stale, and
1809 "no longer available". */
1810 SvPADSTALE_on(PL_curpad[ix]);
1814 PL_curpad = AvARRAY(PL_comppad);
1818 =for apidoc m|void|pad_free|PADOFFSET po
1820 Free the SV at offset po in the current pad.
1825 /* XXX DAPM integrate with pad_swipe ???? */
1827 Perl_pad_free(pTHX_ PADOFFSET po)
1831 ASSERT_CURPAD_LEGAL("pad_free");
1834 if (AvARRAY(PL_comppad) != PL_curpad)
1835 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1836 AvARRAY(PL_comppad), PL_curpad);
1838 Perl_croak(aTHX_ "panic: pad_free po");
1840 DEBUG_X(PerlIO_printf(Perl_debug_log,
1841 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1842 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1847 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1848 SvFLAGS(sv) &= ~SVs_PADTMP;
1850 if ((I32)po < PL_padix)
1855 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1857 Dump the contents of a padlist
1863 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1872 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1877 pad_name = *PadlistARRAY(padlist);
1878 pad = PadlistARRAY(padlist)[1];
1879 pname = AvARRAY(pad_name);
1880 ppad = AvARRAY(pad);
1881 Perl_dump_indent(aTHX_ level, file,
1882 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1883 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1886 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1887 const SV *namesv = pname[ix];
1888 if (namesv && !PadnameLEN(namesv)) {
1893 Perl_dump_indent(aTHX_ level+1, file,
1894 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1897 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1898 SvPVX_const(namesv),
1899 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1900 (unsigned long)PARENT_PAD_INDEX(namesv)
1904 Perl_dump_indent(aTHX_ level+1, file,
1905 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1908 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1909 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1910 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1915 Perl_dump_indent(aTHX_ level+1, file,
1916 "%2d. 0x%"UVxf"<%lu>\n",
1919 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1928 =for apidoc m|void|cv_dump|CV *cv|const char *title
1930 dump the contents of a CV
1936 S_cv_dump(pTHX_ const CV *cv, const char *title)
1939 const CV * const outside = CvOUTSIDE(cv);
1940 PADLIST* const padlist = CvPADLIST(cv);
1942 PERL_ARGS_ASSERT_CV_DUMP;
1944 PerlIO_printf(Perl_debug_log,
1945 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1948 (CvANON(cv) ? "ANON"
1949 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1950 : (cv == PL_main_cv) ? "MAIN"
1951 : CvUNIQUE(cv) ? "UNIQUE"
1952 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1955 : CvANON(outside) ? "ANON"
1956 : (outside == PL_main_cv) ? "MAIN"
1957 : CvUNIQUE(outside) ? "UNIQUE"
1958 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1960 PerlIO_printf(Perl_debug_log,
1961 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1962 do_dump_pad(1, Perl_debug_log, padlist, 1);
1965 #endif /* DEBUGGING */
1968 =for apidoc Am|CV *|cv_clone|CV *proto
1970 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1971 of the function: its code, pad structure, and other attributes.
1972 The prototype is combined with a capture of outer lexicals to which the
1973 code refers, which are taken from the currently-executing instance of
1974 the immediately surrounding code.
1979 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1982 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1986 PADLIST* const protopadlist = CvPADLIST(proto);
1987 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1988 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1989 SV** const pname = AvARRAY(protopad_name);
1990 SV** const ppad = AvARRAY(protopad);
1991 const I32 fname = AvFILLp(protopad_name);
1992 const I32 fpad = AvFILLp(protopad);
1995 bool subclones = FALSE;
1997 assert(!CvUNIQUE(proto));
1999 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2000 * reliable. The currently-running sub is always the one we need to
2002 * For my subs, the currently-running sub may not be the one we want.
2003 * We have to check whether it is a clone of CvOUTSIDE.
2004 * Note that in general for formats, CvOUTSIDE != find_runcv.
2005 * Since formats may be nested inside closures, CvOUTSIDE may point
2006 * to a prototype; we instead want the cloned parent who called us.
2010 if (CvWEAKOUTSIDE(proto))
2011 outside = find_runcv(NULL);
2013 outside = CvOUTSIDE(proto);
2014 if ((CvCLONE(outside) && ! CvCLONED(outside))
2015 || !CvPADLIST(outside)
2016 || PadlistNAMES(CvPADLIST(outside))
2017 != protopadlist->xpadl_outid) {
2018 outside = find_runcv_where(
2019 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2021 /* outside could be null */
2025 depth = outside ? CvDEPTH(outside) : 0;
2030 SAVESPTR(PL_compcv);
2032 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2035 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2037 SAVESPTR(PL_comppad_name);
2038 PL_comppad_name = protopad_name;
2039 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2041 av_fill(PL_comppad, fpad);
2043 PL_curpad = AvARRAY(PL_comppad);
2045 outpad = outside && CvPADLIST(outside)
2046 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2049 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2051 for (ix = fpad; ix > 0; ix--) {
2052 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2054 if (namesv && PadnameLEN(namesv)) { /* lexical */
2055 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2059 if (SvFAKE(namesv)) { /* lexical from outside? */
2060 /* formats may have an inactive, or even undefined, parent;
2061 but state vars are always available. */
2062 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2063 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2064 && (!outside || !CvDEPTH(outside))) ) {
2065 S_unavailable(aTHX_ namesv);
2069 SvREFCNT_inc_simple_void_NN(sv);
2072 const char sigil = SvPVX_const(namesv)[0];
2074 /* If there are state subs, we need to clone them, too.
2075 But they may need to close over variables we have
2076 not cloned yet. So we will have to do a second
2077 pass. Furthermore, there may be state subs clos-
2078 ing over other state subs’ entries, so we have
2079 to put a stub here and then clone into it on the
2081 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2082 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2084 sv = newSV_type(SVt_PVCV);
2086 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2089 /* Just provide a stub, but name it. It will be
2090 upgrade to the real thing on scope entry. */
2091 sv = newSV_type(SVt_PVCV);
2094 share_hek(SvPVX_const(namesv)+1,
2096 * (SvUTF8(namesv) ? -1 : 1),
2100 else sv = SvREFCNT_inc(ppad[ix]);
2101 else if (sigil == '@')
2102 sv = MUTABLE_SV(newAV());
2103 else if (sigil == '%')
2104 sv = MUTABLE_SV(newHV());
2108 /* reset the 'assign only once' flag on each state var */
2109 if (sigil != '&' && SvPAD_STATE(namesv))
2114 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2115 sv = SvREFCNT_inc_NN(ppad[ix]);
2125 for (ix = fpad; ix > 0; ix--) {
2126 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2127 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2128 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2129 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2132 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2137 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2140 const bool newcv = !cv;
2142 assert(!CvUNIQUE(proto));
2144 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2145 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2149 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2152 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2153 else CvGV_set(cv,CvGV(proto));
2154 CvSTASH_set(cv, CvSTASH(proto));
2156 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2158 CvSTART(cv) = CvSTART(proto);
2159 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2162 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2164 SvUTF8_on(MUTABLE_SV(cv));
2167 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2169 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2172 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2173 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2174 cv_dump(proto, "Proto");
2179 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2180 * The prototype was marked as a candiate for const-ization,
2181 * so try to grab the current const value, and if successful,
2182 * turn into a const sub:
2184 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2186 SvREFCNT_dec_NN(cv);
2187 /* For this calling case, op_const_sv returns a *copy*, which we
2188 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2189 Need to fix how lib/constant.pm works to eliminate this. */
2190 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2201 Perl_cv_clone(pTHX_ CV *proto)
2203 PERL_ARGS_ASSERT_CV_CLONE;
2205 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2206 return S_cv_clone(aTHX_ proto, NULL, NULL);
2209 /* Called only by pp_clonecv */
2211 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2213 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2215 return S_cv_clone(aTHX_ proto, target, NULL);
2219 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2221 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2222 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2223 moved to a pre-existing CV struct.
2229 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2233 AV * const comppad_name = PadlistARRAY(padlist)[0];
2234 AV * const comppad = PadlistARRAY(padlist)[1];
2235 SV ** const namepad = AvARRAY(comppad_name);
2236 SV ** const curpad = AvARRAY(comppad);
2238 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2239 PERL_UNUSED_ARG(old_cv);
2241 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2242 const SV * const namesv = namepad[ix];
2243 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2244 && *SvPVX_const(namesv) == '&')
2246 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2248 SvMAGICAL(curpad[ix])
2249 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2251 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2252 if (CvOUTSIDE(innercv) == old_cv) {
2253 if (!CvWEAKOUTSIDE(innercv)) {
2254 SvREFCNT_dec(old_cv);
2255 SvREFCNT_inc_simple_void_NN(new_cv);
2257 CvOUTSIDE(innercv) = new_cv;
2260 else { /* format reference */
2261 SV * const rv = curpad[ix];
2263 if (!SvOK(rv)) continue;
2265 assert(SvWEAKREF(rv));
2266 innercv = (CV *)SvRV(rv);
2267 assert(!CvWEAKOUTSIDE(innercv));
2268 SvREFCNT_dec(CvOUTSIDE(innercv));
2269 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2276 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2278 Push a new pad frame onto the padlist, unless there's already a pad at
2279 this depth, in which case don't bother creating a new one. Then give
2280 the new pad an @_ in slot zero.
2286 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2290 PERL_ARGS_ASSERT_PAD_PUSH;
2292 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2293 PAD** const svp = PadlistARRAY(padlist);
2294 AV* const newpad = newAV();
2295 SV** const oldpad = AvARRAY(svp[depth-1]);
2296 I32 ix = AvFILLp((const AV *)svp[1]);
2297 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2298 SV** const names = AvARRAY(svp[0]);
2301 for ( ;ix > 0; ix--) {
2302 if (names_fill >= ix && PadnameLEN(names[ix])) {
2303 const char sigil = SvPVX_const(names[ix])[0];
2304 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2305 || (SvFLAGS(names[ix]) & SVpad_STATE)
2308 /* outer lexical or anon code */
2309 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2311 else { /* our own lexical */
2314 sv = MUTABLE_SV(newAV());
2315 else if (sigil == '%')
2316 sv = MUTABLE_SV(newHV());
2319 av_store(newpad, ix, sv);
2323 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2324 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2327 /* save temporaries on recursion? */
2328 SV * const sv = newSV(0);
2329 av_store(newpad, ix, sv);
2334 av_store(newpad, 0, MUTABLE_SV(av));
2337 padlist_store(padlist, depth, newpad);
2342 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2344 Looks up the type of the lexical variable at position I<po> in the
2345 currently-compiling pad. If the variable is typed, the stash of the
2346 class to which it is typed is returned. If not, C<NULL> is returned.
2352 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2355 SV* const av = PAD_COMPNAME_SV(po);
2356 if ( SvPAD_TYPED(av) ) {
2362 #if defined(USE_ITHREADS)
2364 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2367 =for apidoc padlist_dup
2375 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2381 PERL_ARGS_ASSERT_PADLIST_DUP;
2386 cloneall = param->flags & CLONEf_COPY_STACKS
2387 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2388 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2390 max = cloneall ? PadlistMAX(srcpad) : 1;
2392 Newx(dstpad, 1, PADLIST);
2393 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2394 PadlistMAX(dstpad) = max;
2395 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2399 for (depth = 0; depth <= max; ++depth)
2400 PadlistARRAY(dstpad)[depth] =
2401 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2403 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2404 to build anything other than the first level of pads. */
2405 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2407 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2408 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2409 SV **oldpad = AvARRAY(srcpad1);
2414 PadlistARRAY(dstpad)[0] =
2415 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2416 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2420 av_extend(pad1, ix);
2421 PadlistARRAY(dstpad)[1] = pad1;
2422 pad1a = AvARRAY(pad1);
2427 for ( ;ix > 0; ix--) {
2430 } else if (names_fill >= ix && names[ix] &&
2431 PadnameLEN(names[ix])) {
2432 const char sigil = SvPVX_const(names[ix])[0];
2433 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2434 || (SvFLAGS(names[ix]) & SVpad_STATE)
2437 /* outer lexical or anon code */
2438 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2440 else { /* our own lexical */
2441 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2442 /* This is a work around for how the current
2443 implementation of ?{ } blocks in regexps
2444 interacts with lexicals. */
2445 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2450 sv = MUTABLE_SV(newAV());
2451 else if (sigil == '%')
2452 sv = MUTABLE_SV(newHV());
2460 else if (IS_PADGV(oldpad[ix])
2461 || ( names_fill >= ix && names[ix]
2462 && PadnamePV(names[ix]) )) {
2463 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2466 /* save temporaries on recursion? */
2467 SV * const sv = newSV(0);
2470 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2471 FIXTHAT before merging this branch.
2472 (And I know how to) */
2473 if (SvPADMY(oldpad[ix]))
2481 args = newAV(); /* Will be @_ */
2483 pad1a[0] = (SV *)args;
2491 #endif /* USE_ITHREADS */
2494 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2498 SSize_t const oldmax = PadlistMAX(padlist);
2500 PERL_ARGS_ASSERT_PADLIST_STORE;
2504 if (key > PadlistMAX(padlist)) {
2505 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2506 (SV ***)&PadlistARRAY(padlist),
2507 (SV ***)&PadlistARRAY(padlist));
2508 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2511 ary = PadlistARRAY(padlist);
2512 SvREFCNT_dec(ary[key]);
2519 * c-indentation-style: bsd
2521 * indent-tabs-mode: nil
2524 * ex: set ts=8 sts=4 sw=4 et: