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)
217 ASSERT_CURPAD_LEGAL("pad_new");
219 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
220 * vars (based on flags) rather than storing vals + addresses for
221 * each individually. Also see pad_block_start.
222 * XXX DAPM Try to see whether all these conditionals are required
225 /* save existing state, ... */
227 if (flags & padnew_SAVE) {
229 if (! (flags & padnew_CLONE)) {
230 SAVESPTR(PL_comppad_name);
232 SAVEI32(PL_comppad_name_fill);
233 SAVEI32(PL_min_intro_pending);
234 SAVEI32(PL_max_intro_pending);
235 SAVEBOOL(PL_cv_has_eval);
236 if (flags & padnew_SAVESUB) {
237 SAVEBOOL(PL_pad_reset_pending);
241 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
242 * saved - check at some pt that this is okay */
244 /* ... create new pad ... */
246 Newxz(padlist, 1, PADLIST);
249 if (flags & padnew_CLONE) {
250 /* XXX DAPM I dont know why cv_clone needs it
251 * doing differently yet - perhaps this separate branch can be
252 * dispensed with eventually ???
255 AV * const a0 = newAV(); /* will be @_ */
256 av_store(pad, 0, MUTABLE_SV(a0));
259 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
262 av_store(pad, 0, NULL);
264 AvPAD_NAMELIST_on(padname);
265 av_store(padname, 0, &PL_sv_undef);
268 /* Most subroutines never recurse, hence only need 2 entries in the padlist
269 array - names, and depth=1. The default for av_store() is to allocate
270 0..3, and even an explicit call to av_extend() with <3 will be rounded
271 up, so we inline the allocation of the array here. */
273 PadlistMAX(padlist) = 1;
274 PadlistARRAY(padlist) = ary;
278 /* ... then update state variables */
281 PL_curpad = AvARRAY(pad);
283 if (! (flags & padnew_CLONE)) {
284 PL_comppad_name = padname;
285 PL_comppad_name_fill = 0;
286 PL_min_intro_pending = 0;
291 DEBUG_X(PerlIO_printf(Perl_debug_log,
292 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
293 " name=0x%"UVxf" flags=0x%"UVxf"\n",
294 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
295 PTR2UV(padname), (UV)flags
299 return (PADLIST*)padlist;
304 =head1 Embedding Functions
308 Clear out all the active components of a CV. This can happen either
309 by an explicit C<undef &foo>, or by the reference count going to zero.
310 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
311 children can still follow the full lexical scope chain.
317 Perl_cv_undef(pTHX_ CV *cv)
319 const PADLIST *padlist = CvPADLIST(cv);
320 bool const slabbed = !!CvSLABBED(cv);
322 PERL_ARGS_ASSERT_CV_UNDEF;
324 DEBUG_X(PerlIO_printf(Perl_debug_log,
325 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
326 PTR2UV(cv), PTR2UV(PL_comppad))
329 if (CvFILE(cv) && CvDYNFILE(cv)) {
330 Safefree(CvFILE(cv));
335 if (!CvISXSUB(cv) && CvROOT(cv)) {
336 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
337 Perl_croak(aTHX_ "Can't undef active subroutine");
340 PAD_SAVE_SETNULLPAD();
342 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
348 else if (slabbed && CvSTART(cv)) {
350 PAD_SAVE_SETNULLPAD();
352 /* discard any leaked ops */
354 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
355 opslab_force_free((OPSLAB *)CvSTART(cv));
361 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
363 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
364 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
365 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
366 else CvGV_set(cv, NULL);
368 /* This statement and the subsequence if block was pad_undef(). */
369 pad_peg("pad_undef");
374 /* Free the padlist associated with a CV.
375 If parts of it happen to be current, we null the relevant PL_*pad*
376 global vars so that we don't have any dangling references left.
377 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
378 subs to the outer of this cv. */
380 DEBUG_X(PerlIO_printf(Perl_debug_log,
381 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
382 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
385 /* detach any '&' anon children in the pad; if afterwards they
386 * are still live, fix up their CvOUTSIDEs to point to our outside,
388 /* XXX DAPM for efficiency, we should only do this if we know we have
389 * children, or integrate this loop with general cleanup */
391 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
392 CV * const outercv = CvOUTSIDE(cv);
393 const U32 seq = CvOUTSIDE_SEQ(cv);
394 PAD * const comppad_name = PadlistARRAY(padlist)[0];
395 SV ** const namepad = AvARRAY(comppad_name);
396 PAD * const comppad = PadlistARRAY(padlist)[1];
397 SV ** const curpad = AvARRAY(comppad);
398 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
399 SV * const namesv = namepad[ix];
400 if (namesv && namesv != &PL_sv_undef
401 && *SvPVX_const(namesv) == '&')
403 CV * const innercv = MUTABLE_CV(curpad[ix]);
404 U32 inner_rc = SvREFCNT(innercv);
406 assert(SvTYPE(innercv) != SVt_PVFM);
408 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
410 SvREFCNT_dec_NN(innercv);
414 /* in use, not just a prototype */
415 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
416 assert(CvWEAKOUTSIDE(innercv));
417 /* don't relink to grandfather if he's being freed */
418 if (outercv && SvREFCNT(outercv)) {
419 CvWEAKOUTSIDE_off(innercv);
420 CvOUTSIDE(innercv) = outercv;
421 CvOUTSIDE_SEQ(innercv) = seq;
422 SvREFCNT_inc_simple_void_NN(outercv);
425 CvOUTSIDE(innercv) = NULL;
432 ix = PadlistMAX(padlist);
434 PAD * const sv = PadlistARRAY(padlist)[ix--];
436 if (sv == PL_comppad) {
444 PAD * const sv = PadlistARRAY(padlist)[0];
445 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
446 PL_comppad_name = NULL;
449 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
451 CvPADLIST(cv) = NULL;
455 /* remove CvOUTSIDE unless this is an undef rather than a free */
456 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
457 if (!CvWEAKOUTSIDE(cv))
458 SvREFCNT_dec(CvOUTSIDE(cv));
459 CvOUTSIDE(cv) = NULL;
462 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
465 if (CvISXSUB(cv) && CvXSUB(cv)) {
468 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
469 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
470 * to choose an error message */
471 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
475 =for apidoc cv_forget_slab
477 When a CV has a reference count on its slab (CvSLABBED), it is responsible
478 for making sure it is freed. (Hence, no two CVs should ever have a
479 reference count on the same slab.) The CV only needs to reference the slab
480 during compilation. Once it is compiled and CvROOT attached, it has
481 finished its job, so it can forget the slab.
487 Perl_cv_forget_slab(pTHX_ CV *cv)
489 const bool slabbed = !!CvSLABBED(cv);
492 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
494 if (!slabbed) return;
498 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
499 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
501 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
505 #ifdef PERL_DEBUG_READONLY_OPS
506 const size_t refcnt = slab->opslab_refcnt;
508 OpslabREFCNT_dec(slab);
509 #ifdef PERL_DEBUG_READONLY_OPS
510 if (refcnt > 1) Slab_to_ro(slab);
516 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
518 Allocates a place in the currently-compiling
519 pad (via L<perlapi/pad_alloc>) and
520 then stores a name for that entry. I<namesv> is adopted and becomes the
521 name entry; it must already contain the name string and be sufficiently
522 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
523 added to I<namesv>. None of the other
524 processing of L<perlapi/pad_add_name_pvn>
525 is done. Returns the offset of the allocated pad slot.
531 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
533 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
535 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
537 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
540 assert(SvTYPE(namesv) == SVt_PVMG);
541 SvPAD_TYPED_on(namesv);
542 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
545 SvPAD_OUR_on(namesv);
546 SvOURSTASH_set(namesv, ourstash);
547 SvREFCNT_inc_simple_void_NN(ourstash);
549 else if (flags & padadd_STATE) {
550 SvPAD_STATE_on(namesv);
553 av_store(PL_comppad_name, offset, namesv);
554 PadnamelistMAXNAMED(PL_comppad_name) = offset;
559 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
561 Allocates a place in the currently-compiling pad for a named lexical
562 variable. Stores the name and other metadata in the name part of the
563 pad, and makes preparations to manage the variable's lexical scoping.
564 Returns the offset of the allocated pad slot.
566 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
567 If I<typestash> is non-null, the name is for a typed lexical, and this
568 identifies the type. If I<ourstash> is non-null, it's a lexical reference
569 to a package variable, and this identifies the package. The following
570 flags can be OR'ed together:
572 padadd_OUR redundantly specifies if it's a package var
573 padadd_STATE variable will retain value persistently
574 padadd_NO_DUP_CHECK skip check for lexical shadowing
580 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
581 U32 flags, HV *typestash, HV *ourstash)
587 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
589 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
590 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
593 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
595 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
596 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
599 sv_setpvn(namesv, namepv, namelen);
602 flags |= padadd_UTF8_NAME;
606 flags &= ~padadd_UTF8_NAME;
608 if ((flags & padadd_NO_DUP_CHECK) == 0) {
610 SAVEFREESV(namesv); /* in case of fatal warnings */
611 /* check for duplicate declaration */
612 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
613 SvREFCNT_inc_simple_void_NN(namesv);
617 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
619 /* not yet introduced */
620 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
621 COP_SEQ_RANGE_HIGH_set(namesv, 0);
623 if (!PL_min_intro_pending)
624 PL_min_intro_pending = offset;
625 PL_max_intro_pending = offset;
626 /* if it's not a simple scalar, replace with an AV or HV */
627 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
628 assert(SvREFCNT(PL_curpad[offset]) == 1);
629 if (namelen != 0 && *namepv == '@')
630 sv_upgrade(PL_curpad[offset], SVt_PVAV);
631 else if (namelen != 0 && *namepv == '%')
632 sv_upgrade(PL_curpad[offset], SVt_PVHV);
633 else if (namelen != 0 && *namepv == '&')
634 sv_upgrade(PL_curpad[offset], SVt_PVCV);
635 assert(SvPADMY(PL_curpad[offset]));
636 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
637 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
638 (long)offset, SvPVX(namesv),
639 PTR2UV(PL_curpad[offset])));
645 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
647 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
648 instead of a string/length pair.
654 Perl_pad_add_name_pv(pTHX_ const char *name,
655 const U32 flags, HV *typestash, HV *ourstash)
657 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
658 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
662 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
664 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
665 of an SV instead of a string/length pair.
671 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
675 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
676 namepv = SvPV(name, namelen);
678 flags |= padadd_UTF8_NAME;
679 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
683 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
685 Allocates a place in the currently-compiling pad,
686 returning the offset of the allocated pad slot.
687 No name is initially attached to the pad slot.
688 I<tmptype> is a set of flags indicating the kind of pad entry required,
689 which will be set in the value SV for the allocated pad entry:
691 SVs_PADMY named lexical variable ("my", "our", "state")
692 SVs_PADTMP unnamed temporary store
693 SVf_READONLY constant shared between recursion levels
695 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
696 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
697 does not cause the SV in the pad slot to be marked read-only, but simply
698 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
699 least should be treated as such.
701 I<optype> should be an opcode indicating the type of operation that the
702 pad entry is to support. This doesn't affect operational semantics,
703 but is used for debugging.
708 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
709 * or at least rationalise ??? */
712 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
717 PERL_UNUSED_ARG(optype);
718 ASSERT_CURPAD_ACTIVE("pad_alloc");
720 if (AvARRAY(PL_comppad) != PL_curpad)
721 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
722 AvARRAY(PL_comppad), PL_curpad);
723 if (PL_pad_reset_pending)
725 if (tmptype & SVs_PADMY) {
726 /* For a my, simply push a null SV onto the end of PL_comppad. */
727 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
728 retval = AvFILLp(PL_comppad);
731 /* For a tmp, scan the pad from PL_padix upwards
732 * for a slot which has no name and no active value.
734 SV * const * const names = AvARRAY(PL_comppad_name);
735 const SSize_t names_fill = AvFILLp(PL_comppad_name);
738 * Entries that close over unavailable variables
739 * in outer subs contain values not marked PADMY.
740 * Thus we must skip, not just pad values that are
741 * marked as current pad values, but also those with names.
743 if (++PL_padix <= names_fill &&
744 (sv = names[PL_padix]) && sv != &PL_sv_undef)
746 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
747 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
751 if (tmptype & SVf_READONLY) {
752 av_store(PL_comppad_name, PL_padix, &PL_sv_no);
753 tmptype &= ~SVf_READONLY;
754 tmptype |= SVs_PADTMP;
758 SvFLAGS(sv) |= tmptype;
759 PL_curpad = AvARRAY(PL_comppad);
761 DEBUG_X(PerlIO_printf(Perl_debug_log,
762 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
763 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
764 PL_op_name[optype]));
765 #ifdef DEBUG_LEAKING_SCALARS
766 sv->sv_debug_optype = optype;
767 sv->sv_debug_inpad = 1;
769 return (PADOFFSET)retval;
773 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
775 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
776 for an anonymous function that is lexically scoped inside the
777 currently-compiling function.
778 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
779 to the outer scope is weakened to avoid a reference loop.
781 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
783 I<optype> should be an opcode indicating the type of operation that the
784 pad entry is to support. This doesn't affect operational semantics,
785 but is used for debugging.
791 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
794 SV* const name = newSV_type(SVt_PVNV);
796 PERL_ARGS_ASSERT_PAD_ADD_ANON;
799 sv_setpvs(name, "&");
800 /* These two aren't used; just make sure they're not equal to
801 * PERL_PADSEQ_INTRO */
802 COP_SEQ_RANGE_LOW_set(name, 0);
803 COP_SEQ_RANGE_HIGH_set(name, 0);
804 ix = pad_alloc(optype, SVs_PADMY);
805 av_store(PL_comppad_name, ix, name);
806 /* XXX DAPM use PL_curpad[] ? */
807 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
808 av_store(PL_comppad, ix, (SV*)func);
810 SV *rv = newRV_noinc((SV *)func);
812 assert (SvTYPE(func) == SVt_PVFM);
813 av_store(PL_comppad, ix, rv);
815 SvPADMY_on((SV*)func);
817 /* to avoid ref loops, we never have parent + child referencing each
818 * other simultaneously */
819 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
820 assert(!CvWEAKOUTSIDE(func));
821 CvWEAKOUTSIDE_on(func);
822 SvREFCNT_dec_NN(CvOUTSIDE(func));
828 =for apidoc pad_check_dup
830 Check for duplicate declarations: report any of:
832 * a my in the current scope with the same name;
833 * an our (anywhere in the pad) with the same name and the
834 same stash as C<ourstash>
836 C<is_our> indicates that the name to check is an 'our' declaration.
842 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
846 const U32 is_our = flags & padadd_OUR;
848 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
850 ASSERT_CURPAD_ACTIVE("pad_check_dup");
852 assert((flags & ~padadd_OUR) == 0);
854 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
855 return; /* nothing to check */
857 svp = AvARRAY(PL_comppad_name);
858 top = AvFILLp(PL_comppad_name);
859 /* check the current scope */
860 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
862 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
863 SV * const sv = svp[off];
867 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
868 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
871 if (is_our && (SvPAD_OUR(sv)))
872 break; /* "our" masking "our" */
873 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
874 Perl_warner(aTHX_ packWARN(WARN_MISC),
875 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
876 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
877 *SvPVX(sv) == '&' ? "subroutine" : "variable",
879 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
880 ? "scope" : "statement"));
885 /* check the rest of the pad */
888 SV * const sv = svp[off];
892 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
893 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
894 && SvOURSTASH(sv) == ourstash
897 Perl_warner(aTHX_ packWARN(WARN_MISC),
898 "\"our\" variable %"SVf" redeclared", SVfARG(sv));
899 if ((I32)off <= PL_comppad_name_floor)
900 Perl_warner(aTHX_ packWARN(WARN_MISC),
901 "\t(Did you mean \"local\" instead of \"our\"?)\n");
911 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
913 Given the name of a lexical variable, find its position in the
914 currently-compiling pad.
915 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
916 I<flags> is reserved and must be zero.
917 If it is not in the current pad but appears in the pad of any lexically
918 enclosing scope, then a pseudo-entry for it is added in the current pad.
919 Returns the offset in the current pad,
920 or C<NOT_IN_PAD> if no such lexical is in scope.
926 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
934 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
936 pad_peg("pad_findmy_pvn");
938 if (flags & ~padadd_UTF8_NAME)
939 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
942 if (flags & padadd_UTF8_NAME) {
944 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
947 flags |= padadd_UTF8_NAME;
949 flags &= ~padadd_UTF8_NAME;
952 offset = pad_findlex(namepv, namelen, flags,
953 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
954 if ((PADOFFSET)offset != NOT_IN_PAD)
957 /* look for an our that's being introduced; this allows
958 * our $foo = 0 unless defined $foo;
959 * to not give a warning. (Yes, this is a hack) */
961 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
962 name_svp = AvARRAY(nameav);
963 for (offset = AvFILLp(nameav); offset > 0; offset--) {
964 const SV * const namesv = name_svp[offset];
965 if (namesv && PadnameLEN(namesv) == namelen
967 && (SvPAD_OUR(namesv))
968 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
969 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
970 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
978 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
980 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
981 instead of a string/length pair.
987 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
989 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
990 return pad_findmy_pvn(name, strlen(name), flags);
994 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
996 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
997 of an SV instead of a string/length pair.
1003 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1007 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1008 namepv = SvPV(name, namelen);
1010 flags |= padadd_UTF8_NAME;
1011 return pad_findmy_pvn(namepv, namelen, flags);
1015 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1017 Find the position of the lexical C<$_> in the pad of the
1018 currently-executing function. Returns the offset in the current pad,
1019 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1020 the global one should be used instead).
1021 L</find_rundefsv> is likely to be more convenient.
1027 Perl_find_rundefsvoffset(pTHX)
1031 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1032 NULL, &out_sv, &out_flags);
1036 =for apidoc Am|SV *|find_rundefsv
1038 Find and return the variable that is named C<$_> in the lexical scope
1039 of the currently-executing function. This may be a lexical C<$_>,
1040 or will otherwise be the global one.
1046 Perl_find_rundefsv(pTHX)
1052 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1053 NULL, &namesv, &flags);
1055 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1062 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1068 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1070 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1071 NULL, &namesv, &flags);
1073 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1076 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1080 =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
1082 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1083 in the inner pads if it's found in an outer one.
1085 Returns the offset in the bottom pad of the lex or the fake lex.
1086 cv is the CV in which to start the search, and seq is the current cop_seq
1087 to match against. If warn is true, print appropriate warnings. The out_*
1088 vars return values, and so are pointers to where the returned values
1089 should be stored. out_capture, if non-null, requests that the innermost
1090 instance of the lexical is captured; out_name_sv is set to the innermost
1091 matched namesv or fake namesv; out_flags returns the flags normally
1092 associated with the IVX field of a fake namesv.
1094 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1095 then comes back down, adding fake entries
1096 as it goes. It has to be this way
1097 because fake namesvs in anon protoypes have to store in xlow the index into
1103 /* the CV has finished being compiled. This is not a sufficient test for
1104 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1105 #define CvCOMPILED(cv) CvROOT(cv)
1107 /* the CV does late binding of its lexicals */
1108 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1111 S_unavailable(pTHX_ SV *namesv)
1113 /* diag_listed_as: Variable "%s" is not available */
1114 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1115 "%se \"%"SVf"\" is not available",
1116 *SvPVX_const(namesv) == '&'
1123 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1124 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1126 I32 offset, new_offset;
1129 const PADLIST * const padlist = CvPADLIST(cv);
1130 const bool staleok = !!(flags & padadd_STALEOK);
1132 PERL_ARGS_ASSERT_PAD_FINDLEX;
1134 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1135 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1137 flags &= ~ padadd_STALEOK; /* one-shot flag */
1141 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1142 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1143 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1144 out_capture ? " capturing" : "" ));
1146 /* first, search this pad */
1148 if (padlist) { /* not an undef CV */
1149 I32 fake_offset = 0;
1150 const AV * const nameav = PadlistARRAY(padlist)[0];
1151 SV * const * const name_svp = AvARRAY(nameav);
1153 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1154 const SV * const namesv = name_svp[offset];
1155 if (namesv && PadnameLEN(namesv) == namelen
1156 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1157 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1159 if (SvFAKE(namesv)) {
1160 fake_offset = offset; /* in case we don't find a real one */
1163 /* is seq within the range _LOW to _HIGH ?
1164 * This is complicated by the fact that PL_cop_seqmax
1165 * may have wrapped around at some point */
1166 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1167 continue; /* not yet introduced */
1169 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1170 /* in compiling scope */
1172 (seq > COP_SEQ_RANGE_LOW(namesv))
1173 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1174 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1179 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1181 ( seq > COP_SEQ_RANGE_LOW(namesv)
1182 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1184 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1185 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1191 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1192 if (offset > 0) { /* not fake */
1194 *out_name_sv = name_svp[offset]; /* return the namesv */
1196 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1197 * instances. For now, we just test !CvUNIQUE(cv), but
1198 * ideally, we should detect my's declared within loops
1199 * etc - this would allow a wider range of 'not stayed
1200 * shared' warnings. We also treated already-compiled
1201 * lexes as not multi as viewed from evals. */
1203 *out_flags = CvANON(cv) ?
1205 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1206 ? PAD_FAKELEX_MULTI : 0;
1208 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1209 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1210 PTR2UV(cv), (long)offset,
1211 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1212 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1214 else { /* fake match */
1215 offset = fake_offset;
1216 *out_name_sv = name_svp[offset]; /* return the namesv */
1217 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1218 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1219 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1220 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1221 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1225 /* return the lex? */
1230 if (SvPAD_OUR(*out_name_sv)) {
1231 *out_capture = NULL;
1235 /* trying to capture from an anon prototype? */
1237 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1238 : *out_flags & PAD_FAKELEX_ANON)
1242 newSVpvn_flags(namepv, namelen,
1244 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1246 *out_capture = NULL;
1252 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1253 && !SvPAD_STATE(name_svp[offset])
1254 && warn && ckWARN(WARN_CLOSURE)) {
1256 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1257 "Variable \"%"SVf"\" will not stay shared",
1258 SVfARG(newSVpvn_flags(namepv, namelen,
1260 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1263 if (fake_offset && CvANON(cv)
1264 && CvCLONE(cv) &&!CvCLONED(cv))
1267 /* not yet caught - look further up */
1268 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1269 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1272 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1274 newwarn, out_capture, out_name_sv, out_flags);
1279 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1280 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1281 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1282 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1283 PTR2UV(cv), PTR2UV(*out_capture)));
1285 if (SvPADSTALE(*out_capture)
1286 && (!CvDEPTH(cv) || !staleok)
1287 && !SvPAD_STATE(name_svp[offset]))
1290 newSVpvn_flags(namepv, namelen,
1292 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1293 *out_capture = NULL;
1296 if (!*out_capture) {
1297 if (namelen != 0 && *namepv == '@')
1298 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1299 else if (namelen != 0 && *namepv == '%')
1300 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1301 else if (namelen != 0 && *namepv == '&')
1302 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1304 *out_capture = sv_newmortal();
1312 /* it's not in this pad - try above */
1317 /* out_capture non-null means caller wants us to capture lex; in
1318 * addition we capture ourselves unless it's an ANON/format */
1319 new_capturep = out_capture ? out_capture :
1320 CvLATE(cv) ? NULL : &new_capture;
1322 offset = pad_findlex(namepv, namelen,
1323 flags | padadd_STALEOK*(new_capturep == &new_capture),
1324 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1325 new_capturep, out_name_sv, out_flags);
1326 if ((PADOFFSET)offset == NOT_IN_PAD)
1329 /* found in an outer CV. Add appropriate fake entry to this pad */
1331 /* don't add new fake entries (via eval) to CVs that we have already
1332 * finished compiling, or to undef CVs */
1333 if (CvCOMPILED(cv) || !padlist)
1334 return 0; /* this dummy (and invalid) value isnt used by the caller */
1337 /* This relies on sv_setsv_flags() upgrading the destination to the same
1338 type as the source, independent of the flags set, and on it being
1339 "good" and only copying flag bits and pointers that it understands.
1341 SV *new_namesv = newSVsv(*out_name_sv);
1342 AV * const ocomppad_name = PL_comppad_name;
1343 PAD * const ocomppad = PL_comppad;
1344 PL_comppad_name = PadlistARRAY(padlist)[0];
1345 PL_comppad = PadlistARRAY(padlist)[1];
1346 PL_curpad = AvARRAY(PL_comppad);
1349 = pad_alloc_name(new_namesv,
1350 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1351 SvPAD_TYPED(*out_name_sv)
1352 ? SvSTASH(*out_name_sv) : NULL,
1353 SvOURSTASH(*out_name_sv)
1356 SvFAKE_on(new_namesv);
1357 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1358 "Pad addname: %ld \"%.*s\" FAKE\n",
1360 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1361 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1363 PARENT_PAD_INDEX_set(new_namesv, 0);
1364 if (SvPAD_OUR(new_namesv)) {
1365 NOOP; /* do nothing */
1367 else if (CvLATE(cv)) {
1368 /* delayed creation - just note the offset within parent pad */
1369 PARENT_PAD_INDEX_set(new_namesv, offset);
1373 /* immediate creation - capture outer value right now */
1374 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1375 /* But also note the offset, as newMYSUB needs it */
1376 PARENT_PAD_INDEX_set(new_namesv, offset);
1377 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1378 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1379 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1381 *out_name_sv = new_namesv;
1382 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1384 PL_comppad_name = ocomppad_name;
1385 PL_comppad = ocomppad;
1386 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1394 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1396 Get the value at offset I<po> in the current (compiling or executing) pad.
1397 Use macro PAD_SV instead of calling this function directly.
1403 Perl_pad_sv(pTHX_ PADOFFSET po)
1406 ASSERT_CURPAD_ACTIVE("pad_sv");
1409 Perl_croak(aTHX_ "panic: pad_sv po");
1410 DEBUG_X(PerlIO_printf(Perl_debug_log,
1411 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1412 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1414 return PL_curpad[po];
1418 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1420 Set the value at offset I<po> in the current (compiling or executing) pad.
1421 Use the macro PAD_SETSV() rather than calling this function directly.
1427 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1431 PERL_ARGS_ASSERT_PAD_SETSV;
1433 ASSERT_CURPAD_ACTIVE("pad_setsv");
1435 DEBUG_X(PerlIO_printf(Perl_debug_log,
1436 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1437 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1442 #endif /* DEBUGGING */
1445 =for apidoc m|void|pad_block_start|int full
1447 Update the pad compilation state variables on entry to a new block.
1452 /* XXX DAPM perhaps:
1453 * - integrate this in general state-saving routine ???
1454 * - combine with the state-saving going on in pad_new ???
1455 * - introduce a new SAVE type that does all this in one go ?
1459 Perl_pad_block_start(pTHX_ int full)
1461 ASSERT_CURPAD_ACTIVE("pad_block_start");
1462 SAVEI32(PL_comppad_name_floor);
1463 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1465 PL_comppad_name_fill = PL_comppad_name_floor;
1466 if (PL_comppad_name_floor < 0)
1467 PL_comppad_name_floor = 0;
1468 SAVEI32(PL_min_intro_pending);
1469 SAVEI32(PL_max_intro_pending);
1470 PL_min_intro_pending = 0;
1471 SAVEI32(PL_comppad_name_fill);
1472 SAVEI32(PL_padix_floor);
1473 PL_padix_floor = PL_padix;
1474 PL_pad_reset_pending = FALSE;
1478 =for apidoc m|U32|intro_my
1480 "Introduce" my variables to visible status. This is called during parsing
1481 at the end of each statement to make lexical variables visible to
1482 subsequent statements.
1494 ASSERT_CURPAD_ACTIVE("intro_my");
1495 if (! PL_min_intro_pending)
1496 return PL_cop_seqmax;
1498 svp = AvARRAY(PL_comppad_name);
1499 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1500 SV * const sv = svp[i];
1502 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1503 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1505 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1506 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1507 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1508 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1509 (long)i, SvPVX_const(sv),
1510 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1511 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1515 seq = PL_cop_seqmax;
1517 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1519 PL_min_intro_pending = 0;
1520 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1521 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1522 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1528 =for apidoc m|void|pad_leavemy
1530 Cleanup at end of scope during compilation: set the max seq number for
1531 lexicals in this scope and warn of any lexicals that never got introduced.
1537 Perl_pad_leavemy(pTHX)
1541 SV * const * const svp = AvARRAY(PL_comppad_name);
1543 PL_pad_reset_pending = FALSE;
1545 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1546 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1547 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1548 const SV * const sv = svp[off];
1549 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1550 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1551 "%"SVf" never introduced",
1555 /* "Deintroduce" my variables that are leaving with this scope. */
1556 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1557 SV * const sv = svp[off];
1558 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1559 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1561 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1562 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1563 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1564 (long)off, SvPVX_const(sv),
1565 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1566 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1568 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1569 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1570 OP *kid = newOP(OP_INTROCV, 0);
1572 o = op_prepend_elem(OP_LINESEQ, kid, o);
1577 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1579 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1580 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1585 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1587 Abandon the tmp in the current pad at offset po and replace with a
1594 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1596 ASSERT_CURPAD_LEGAL("pad_swipe");
1599 if (AvARRAY(PL_comppad) != PL_curpad)
1600 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1601 AvARRAY(PL_comppad), PL_curpad);
1602 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1603 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1604 (long)po, (long)AvFILLp(PL_comppad));
1606 DEBUG_X(PerlIO_printf(Perl_debug_log,
1607 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1608 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1611 SvREFCNT_dec(PL_curpad[po]);
1614 /* if pad tmps aren't shared between ops, then there's no need to
1615 * create a new tmp when an existing op is freed */
1616 #ifdef USE_BROKEN_PAD_RESET
1617 PL_curpad[po] = newSV(0);
1618 SvPADTMP_on(PL_curpad[po]);
1620 PL_curpad[po] = NULL;
1622 if (PadnamelistMAX(PL_comppad_name) != -1
1623 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1624 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1625 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1627 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1629 if ((I32)po < PL_padix)
1634 =for apidoc m|void|pad_reset
1636 Mark all the current temporaries for reuse
1641 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1642 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1643 * on the stack by OPs that use them, there are several ways to get an alias
1644 * to a shared TARG. Such an alias will change randomly and unpredictably.
1645 * We avoid doing this until we can think of a Better Way.
1650 #ifdef USE_BROKEN_PAD_RESET
1651 if (AvARRAY(PL_comppad) != PL_curpad)
1652 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1653 AvARRAY(PL_comppad), PL_curpad);
1655 DEBUG_X(PerlIO_printf(Perl_debug_log,
1656 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1657 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1658 (long)PL_padix, (long)PL_padix_floor
1662 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1664 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1665 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1666 SvPADTMP_off(PL_curpad[po]);
1668 PL_padix = PL_padix_floor;
1671 PL_pad_reset_pending = FALSE;
1675 =for apidoc Amx|void|pad_tidy|padtidy_type type
1677 Tidy up a pad at the end of compilation of the code to which it belongs.
1678 Jobs performed here are: remove most stuff from the pads of anonsub
1679 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1680 the kind of subroutine:
1682 padtidy_SUB ordinary subroutine
1683 padtidy_SUBCLONE prototype for lexical closure
1684 padtidy_FORMAT format
1689 /* XXX DAPM surely most of this stuff should be done properly
1690 * at the right time beforehand, rather than going around afterwards
1691 * cleaning up our mistakes ???
1695 Perl_pad_tidy(pTHX_ padtidy_type type)
1699 ASSERT_CURPAD_ACTIVE("pad_tidy");
1701 /* If this CV has had any 'eval-capable' ops planted in it:
1702 * i.e. it contains any of:
1706 * * use re 'eval'; /$var/
1709 * Then any anon prototypes in the chain of CVs should be marked as
1710 * cloneable, so that for example the eval's CV in
1714 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1715 * potentially have an eval executed within it.
1718 if (PL_cv_has_eval || PL_perldb) {
1720 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1721 if (cv != PL_compcv && CvCOMPILED(cv))
1722 break; /* no need to mark already-compiled code */
1724 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1725 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1732 /* extend namepad to match curpad */
1733 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1734 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1736 if (type == padtidy_SUBCLONE) {
1737 SV ** const namep = AvARRAY(PL_comppad_name);
1740 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1742 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1745 * The only things that a clonable function needs in its
1746 * pad are anonymous subs, constants and GVs.
1747 * The rest are created anew during cloning.
1749 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1750 || IS_PADGV(PL_curpad[ix]))
1753 if (!(PadnamePV(namesv) &&
1754 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1756 SvREFCNT_dec(PL_curpad[ix]);
1757 PL_curpad[ix] = NULL;
1761 else if (type == padtidy_SUB) {
1762 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1763 AV * const av = newAV(); /* Will be @_ */
1764 av_store(PL_comppad, 0, MUTABLE_SV(av));
1768 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1769 SV ** const namep = AvARRAY(PL_comppad_name);
1771 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1772 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1773 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1774 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1776 if (!SvPADMY(PL_curpad[ix])) {
1777 SvPADTMP_on(PL_curpad[ix]);
1778 } else if (!SvFAKE(namep[ix])) {
1779 /* This is a work around for how the current implementation of
1780 ?{ } blocks in regexps interacts with lexicals.
1782 One of our lexicals.
1783 Can't do this on all lexicals, otherwise sub baz() won't
1792 because completion of compiling &bar calling pad_tidy()
1793 would cause (top level) $foo to be marked as stale, and
1794 "no longer available". */
1795 SvPADSTALE_on(PL_curpad[ix]);
1799 PL_curpad = AvARRAY(PL_comppad);
1803 =for apidoc m|void|pad_free|PADOFFSET po
1805 Free the SV at offset po in the current pad.
1810 /* XXX DAPM integrate with pad_swipe ???? */
1812 Perl_pad_free(pTHX_ PADOFFSET po)
1815 ASSERT_CURPAD_LEGAL("pad_free");
1818 if (AvARRAY(PL_comppad) != PL_curpad)
1819 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1820 AvARRAY(PL_comppad), PL_curpad);
1822 Perl_croak(aTHX_ "panic: pad_free po");
1824 DEBUG_X(PerlIO_printf(Perl_debug_log,
1825 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1826 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1831 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1832 SvFLAGS(sv) &= ~SVs_PADTMP;
1834 if ((I32)po < PL_padix)
1839 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1841 Dump the contents of a padlist
1847 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1855 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1860 pad_name = *PadlistARRAY(padlist);
1861 pad = PadlistARRAY(padlist)[1];
1862 pname = AvARRAY(pad_name);
1863 ppad = AvARRAY(pad);
1864 Perl_dump_indent(aTHX_ level, file,
1865 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1866 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1869 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1870 const SV *namesv = pname[ix];
1871 if (namesv && !PadnameLEN(namesv)) {
1876 Perl_dump_indent(aTHX_ level+1, file,
1877 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1880 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1881 SvPVX_const(namesv),
1882 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1883 (unsigned long)PARENT_PAD_INDEX(namesv)
1887 Perl_dump_indent(aTHX_ level+1, file,
1888 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1891 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1892 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1893 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1898 Perl_dump_indent(aTHX_ level+1, file,
1899 "%2d. 0x%"UVxf"<%lu>\n",
1902 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1911 =for apidoc m|void|cv_dump|CV *cv|const char *title
1913 dump the contents of a CV
1919 S_cv_dump(pTHX_ const CV *cv, const char *title)
1922 const CV * const outside = CvOUTSIDE(cv);
1923 PADLIST* const padlist = CvPADLIST(cv);
1925 PERL_ARGS_ASSERT_CV_DUMP;
1927 PerlIO_printf(Perl_debug_log,
1928 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1931 (CvANON(cv) ? "ANON"
1932 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1933 : (cv == PL_main_cv) ? "MAIN"
1934 : CvUNIQUE(cv) ? "UNIQUE"
1935 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1938 : CvANON(outside) ? "ANON"
1939 : (outside == PL_main_cv) ? "MAIN"
1940 : CvUNIQUE(outside) ? "UNIQUE"
1941 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1943 PerlIO_printf(Perl_debug_log,
1944 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1945 do_dump_pad(1, Perl_debug_log, padlist, 1);
1948 #endif /* DEBUGGING */
1951 =for apidoc Am|CV *|cv_clone|CV *proto
1953 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1954 of the function: its code, pad structure, and other attributes.
1955 The prototype is combined with a capture of outer lexicals to which the
1956 code refers, which are taken from the currently-executing instance of
1957 the immediately surrounding code.
1962 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1965 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1968 PADLIST* const protopadlist = CvPADLIST(proto);
1969 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1970 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1971 SV** const pname = AvARRAY(protopad_name);
1972 SV** const ppad = AvARRAY(protopad);
1973 const I32 fname = AvFILLp(protopad_name);
1974 const I32 fpad = AvFILLp(protopad);
1977 bool subclones = FALSE;
1979 assert(!CvUNIQUE(proto));
1981 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1982 * reliable. The currently-running sub is always the one we need to
1984 * For my subs, the currently-running sub may not be the one we want.
1985 * We have to check whether it is a clone of CvOUTSIDE.
1986 * Note that in general for formats, CvOUTSIDE != find_runcv.
1987 * Since formats may be nested inside closures, CvOUTSIDE may point
1988 * to a prototype; we instead want the cloned parent who called us.
1992 if (CvWEAKOUTSIDE(proto))
1993 outside = find_runcv(NULL);
1995 outside = CvOUTSIDE(proto);
1996 if ((CvCLONE(outside) && ! CvCLONED(outside))
1997 || !CvPADLIST(outside)
1998 || PadlistNAMES(CvPADLIST(outside))
1999 != protopadlist->xpadl_outid) {
2000 outside = find_runcv_where(
2001 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2003 /* outside could be null */
2007 depth = outside ? CvDEPTH(outside) : 0;
2012 SAVESPTR(PL_compcv);
2014 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2017 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2019 SAVESPTR(PL_comppad_name);
2020 PL_comppad_name = protopad_name;
2021 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2023 av_fill(PL_comppad, fpad);
2025 PL_curpad = AvARRAY(PL_comppad);
2027 outpad = outside && CvPADLIST(outside)
2028 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2031 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2033 for (ix = fpad; ix > 0; ix--) {
2034 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2036 if (namesv && PadnameLEN(namesv)) { /* lexical */
2037 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2041 if (SvFAKE(namesv)) { /* lexical from outside? */
2042 /* formats may have an inactive, or even undefined, parent;
2043 but state vars are always available. */
2044 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2045 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2046 && (!outside || !CvDEPTH(outside))) ) {
2047 S_unavailable(aTHX_ namesv);
2051 SvREFCNT_inc_simple_void_NN(sv);
2054 const char sigil = SvPVX_const(namesv)[0];
2056 /* If there are state subs, we need to clone them, too.
2057 But they may need to close over variables we have
2058 not cloned yet. So we will have to do a second
2059 pass. Furthermore, there may be state subs clos-
2060 ing over other state subs’ entries, so we have
2061 to put a stub here and then clone into it on the
2063 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2064 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2066 sv = newSV_type(SVt_PVCV);
2068 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2071 /* Just provide a stub, but name it. It will be
2072 upgrade to the real thing on scope entry. */
2073 sv = newSV_type(SVt_PVCV);
2076 share_hek(SvPVX_const(namesv)+1,
2078 * (SvUTF8(namesv) ? -1 : 1),
2082 else sv = SvREFCNT_inc(ppad[ix]);
2083 else if (sigil == '@')
2084 sv = MUTABLE_SV(newAV());
2085 else if (sigil == '%')
2086 sv = MUTABLE_SV(newHV());
2090 /* reset the 'assign only once' flag on each state var */
2091 if (sigil != '&' && SvPAD_STATE(namesv))
2096 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2097 sv = SvREFCNT_inc_NN(ppad[ix]);
2107 for (ix = fpad; ix > 0; ix--) {
2108 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2109 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2110 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2111 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2114 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2119 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2124 const bool newcv = !cv;
2126 assert(!CvUNIQUE(proto));
2128 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2129 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2133 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2136 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2137 else CvGV_set(cv,CvGV(proto));
2138 CvSTASH_set(cv, CvSTASH(proto));
2140 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2142 CvSTART(cv) = CvSTART(proto);
2143 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2146 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2148 SvUTF8_on(MUTABLE_SV(cv));
2151 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2153 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2156 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2157 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2158 cv_dump(proto, "Proto");
2163 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2164 * The prototype was marked as a candiate for const-ization,
2165 * so try to grab the current const value, and if successful,
2166 * turn into a const sub:
2168 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2170 SvREFCNT_dec_NN(cv);
2171 /* For this calling case, op_const_sv returns a *copy*, which we
2172 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2173 Need to fix how lib/constant.pm works to eliminate this. */
2174 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2185 Perl_cv_clone(pTHX_ CV *proto)
2187 PERL_ARGS_ASSERT_CV_CLONE;
2189 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2190 return S_cv_clone(aTHX_ proto, NULL, NULL);
2193 /* Called only by pp_clonecv */
2195 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2197 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2199 return S_cv_clone(aTHX_ proto, target, NULL);
2203 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2205 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2206 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2207 moved to a pre-existing CV struct.
2213 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2216 AV * const comppad_name = PadlistARRAY(padlist)[0];
2217 AV * const comppad = PadlistARRAY(padlist)[1];
2218 SV ** const namepad = AvARRAY(comppad_name);
2219 SV ** const curpad = AvARRAY(comppad);
2221 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2222 PERL_UNUSED_ARG(old_cv);
2224 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2225 const SV * const namesv = namepad[ix];
2226 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2227 && *SvPVX_const(namesv) == '&')
2229 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2231 SvMAGICAL(curpad[ix])
2232 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2234 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2235 if (CvOUTSIDE(innercv) == old_cv) {
2236 if (!CvWEAKOUTSIDE(innercv)) {
2237 SvREFCNT_dec(old_cv);
2238 SvREFCNT_inc_simple_void_NN(new_cv);
2240 CvOUTSIDE(innercv) = new_cv;
2243 else { /* format reference */
2244 SV * const rv = curpad[ix];
2246 if (!SvOK(rv)) continue;
2248 assert(SvWEAKREF(rv));
2249 innercv = (CV *)SvRV(rv);
2250 assert(!CvWEAKOUTSIDE(innercv));
2251 SvREFCNT_dec(CvOUTSIDE(innercv));
2252 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2259 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2261 Push a new pad frame onto the padlist, unless there's already a pad at
2262 this depth, in which case don't bother creating a new one. Then give
2263 the new pad an @_ in slot zero.
2269 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2271 PERL_ARGS_ASSERT_PAD_PUSH;
2273 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2274 PAD** const svp = PadlistARRAY(padlist);
2275 AV* const newpad = newAV();
2276 SV** const oldpad = AvARRAY(svp[depth-1]);
2277 I32 ix = AvFILLp((const AV *)svp[1]);
2278 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2279 SV** const names = AvARRAY(svp[0]);
2282 for ( ;ix > 0; ix--) {
2283 if (names_fill >= ix && PadnameLEN(names[ix])) {
2284 const char sigil = SvPVX_const(names[ix])[0];
2285 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2286 || (SvFLAGS(names[ix]) & SVpad_STATE)
2289 /* outer lexical or anon code */
2290 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2292 else { /* our own lexical */
2295 sv = MUTABLE_SV(newAV());
2296 else if (sigil == '%')
2297 sv = MUTABLE_SV(newHV());
2300 av_store(newpad, ix, sv);
2304 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2305 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2308 /* save temporaries on recursion? */
2309 SV * const sv = newSV(0);
2310 av_store(newpad, ix, sv);
2315 av_store(newpad, 0, MUTABLE_SV(av));
2318 padlist_store(padlist, depth, newpad);
2323 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2325 Looks up the type of the lexical variable at position I<po> in the
2326 currently-compiling pad. If the variable is typed, the stash of the
2327 class to which it is typed is returned. If not, C<NULL> is returned.
2333 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2335 SV* const av = PAD_COMPNAME_SV(po);
2336 if ( SvPAD_TYPED(av) ) {
2342 #if defined(USE_ITHREADS)
2344 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2347 =for apidoc padlist_dup
2355 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2361 PERL_ARGS_ASSERT_PADLIST_DUP;
2366 cloneall = param->flags & CLONEf_COPY_STACKS
2367 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2368 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2370 max = cloneall ? PadlistMAX(srcpad) : 1;
2372 Newx(dstpad, 1, PADLIST);
2373 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2374 PadlistMAX(dstpad) = max;
2375 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2379 for (depth = 0; depth <= max; ++depth)
2380 PadlistARRAY(dstpad)[depth] =
2381 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2383 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2384 to build anything other than the first level of pads. */
2385 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2387 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2388 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2389 SV **oldpad = AvARRAY(srcpad1);
2394 PadlistARRAY(dstpad)[0] =
2395 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2396 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2400 av_extend(pad1, ix);
2401 PadlistARRAY(dstpad)[1] = pad1;
2402 pad1a = AvARRAY(pad1);
2407 for ( ;ix > 0; ix--) {
2410 } else if (names_fill >= ix && names[ix] &&
2411 PadnameLEN(names[ix])) {
2412 const char sigil = SvPVX_const(names[ix])[0];
2413 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2414 || (SvFLAGS(names[ix]) & SVpad_STATE)
2417 /* outer lexical or anon code */
2418 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2420 else { /* our own lexical */
2421 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2422 /* This is a work around for how the current
2423 implementation of ?{ } blocks in regexps
2424 interacts with lexicals. */
2425 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2430 sv = MUTABLE_SV(newAV());
2431 else if (sigil == '%')
2432 sv = MUTABLE_SV(newHV());
2440 else if (IS_PADGV(oldpad[ix])
2441 || ( names_fill >= ix && names[ix]
2442 && PadnamePV(names[ix]) )) {
2443 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2446 /* save temporaries on recursion? */
2447 SV * const sv = newSV(0);
2450 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2451 FIXTHAT before merging this branch.
2452 (And I know how to) */
2453 if (SvPADMY(oldpad[ix]))
2461 args = newAV(); /* Will be @_ */
2463 pad1a[0] = (SV *)args;
2471 #endif /* USE_ITHREADS */
2474 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2477 SSize_t const oldmax = PadlistMAX(padlist);
2479 PERL_ARGS_ASSERT_PADLIST_STORE;
2483 if (key > PadlistMAX(padlist)) {
2484 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2485 (SV ***)&PadlistARRAY(padlist),
2486 (SV ***)&PadlistARRAY(padlist));
2487 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2490 ary = PadlistARRAY(padlist);
2491 SvREFCNT_dec(ary[key]);
2498 * c-indentation-style: bsd
2500 * indent-tabs-mode: nil
2503 * ex: set ts=8 sts=4 sw=4 et: