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)
1405 ASSERT_CURPAD_ACTIVE("pad_sv");
1408 Perl_croak(aTHX_ "panic: pad_sv po");
1409 DEBUG_X(PerlIO_printf(Perl_debug_log,
1410 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1411 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1413 return PL_curpad[po];
1417 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1419 Set the value at offset I<po> in the current (compiling or executing) pad.
1420 Use the macro PAD_SETSV() rather than calling this function directly.
1426 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1428 PERL_ARGS_ASSERT_PAD_SETSV;
1430 ASSERT_CURPAD_ACTIVE("pad_setsv");
1432 DEBUG_X(PerlIO_printf(Perl_debug_log,
1433 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1434 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1439 #endif /* DEBUGGING */
1442 =for apidoc m|void|pad_block_start|int full
1444 Update the pad compilation state variables on entry to a new block.
1449 /* XXX DAPM perhaps:
1450 * - integrate this in general state-saving routine ???
1451 * - combine with the state-saving going on in pad_new ???
1452 * - introduce a new SAVE type that does all this in one go ?
1456 Perl_pad_block_start(pTHX_ int full)
1458 ASSERT_CURPAD_ACTIVE("pad_block_start");
1459 SAVEI32(PL_comppad_name_floor);
1460 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1462 PL_comppad_name_fill = PL_comppad_name_floor;
1463 if (PL_comppad_name_floor < 0)
1464 PL_comppad_name_floor = 0;
1465 SAVEI32(PL_min_intro_pending);
1466 SAVEI32(PL_max_intro_pending);
1467 PL_min_intro_pending = 0;
1468 SAVEI32(PL_comppad_name_fill);
1469 SAVEI32(PL_padix_floor);
1470 PL_padix_floor = PL_padix;
1471 PL_pad_reset_pending = FALSE;
1475 =for apidoc m|U32|intro_my
1477 "Introduce" my variables to visible status. This is called during parsing
1478 at the end of each statement to make lexical variables visible to
1479 subsequent statements.
1491 ASSERT_CURPAD_ACTIVE("intro_my");
1492 if (! PL_min_intro_pending)
1493 return PL_cop_seqmax;
1495 svp = AvARRAY(PL_comppad_name);
1496 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1497 SV * const sv = svp[i];
1499 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1500 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1502 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1503 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1504 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1505 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1506 (long)i, SvPVX_const(sv),
1507 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1508 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1512 seq = PL_cop_seqmax;
1514 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1516 PL_min_intro_pending = 0;
1517 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1518 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1519 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1525 =for apidoc m|void|pad_leavemy
1527 Cleanup at end of scope during compilation: set the max seq number for
1528 lexicals in this scope and warn of any lexicals that never got introduced.
1534 Perl_pad_leavemy(pTHX)
1538 SV * const * const svp = AvARRAY(PL_comppad_name);
1540 PL_pad_reset_pending = FALSE;
1542 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1543 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1544 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1545 const SV * const sv = svp[off];
1546 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1547 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1548 "%"SVf" never introduced",
1552 /* "Deintroduce" my variables that are leaving with this scope. */
1553 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1554 SV * const sv = svp[off];
1555 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1556 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1558 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1559 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1560 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1561 (long)off, SvPVX_const(sv),
1562 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1563 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1565 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1566 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1567 OP *kid = newOP(OP_INTROCV, 0);
1569 o = op_prepend_elem(OP_LINESEQ, kid, o);
1574 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1576 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1577 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1582 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1584 Abandon the tmp in the current pad at offset po and replace with a
1591 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1593 ASSERT_CURPAD_LEGAL("pad_swipe");
1596 if (AvARRAY(PL_comppad) != PL_curpad)
1597 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1598 AvARRAY(PL_comppad), PL_curpad);
1599 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1600 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1601 (long)po, (long)AvFILLp(PL_comppad));
1603 DEBUG_X(PerlIO_printf(Perl_debug_log,
1604 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1605 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1608 SvREFCNT_dec(PL_curpad[po]);
1611 /* if pad tmps aren't shared between ops, then there's no need to
1612 * create a new tmp when an existing op is freed */
1613 #ifdef USE_BROKEN_PAD_RESET
1614 PL_curpad[po] = newSV(0);
1615 SvPADTMP_on(PL_curpad[po]);
1617 PL_curpad[po] = NULL;
1619 if (PadnamelistMAX(PL_comppad_name) != -1
1620 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1621 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1622 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1624 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1626 if ((I32)po < PL_padix)
1631 =for apidoc m|void|pad_reset
1633 Mark all the current temporaries for reuse
1638 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1639 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1640 * on the stack by OPs that use them, there are several ways to get an alias
1641 * to a shared TARG. Such an alias will change randomly and unpredictably.
1642 * We avoid doing this until we can think of a Better Way.
1647 #ifdef USE_BROKEN_PAD_RESET
1648 if (AvARRAY(PL_comppad) != PL_curpad)
1649 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1650 AvARRAY(PL_comppad), PL_curpad);
1652 DEBUG_X(PerlIO_printf(Perl_debug_log,
1653 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1654 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1655 (long)PL_padix, (long)PL_padix_floor
1659 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1661 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1662 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1663 SvPADTMP_off(PL_curpad[po]);
1665 PL_padix = PL_padix_floor;
1668 PL_pad_reset_pending = FALSE;
1672 =for apidoc Amx|void|pad_tidy|padtidy_type type
1674 Tidy up a pad at the end of compilation of the code to which it belongs.
1675 Jobs performed here are: remove most stuff from the pads of anonsub
1676 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1677 the kind of subroutine:
1679 padtidy_SUB ordinary subroutine
1680 padtidy_SUBCLONE prototype for lexical closure
1681 padtidy_FORMAT format
1686 /* XXX DAPM surely most of this stuff should be done properly
1687 * at the right time beforehand, rather than going around afterwards
1688 * cleaning up our mistakes ???
1692 Perl_pad_tidy(pTHX_ padtidy_type type)
1696 ASSERT_CURPAD_ACTIVE("pad_tidy");
1698 /* If this CV has had any 'eval-capable' ops planted in it:
1699 * i.e. it contains any of:
1703 * * use re 'eval'; /$var/
1706 * Then any anon prototypes in the chain of CVs should be marked as
1707 * cloneable, so that for example the eval's CV in
1711 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1712 * potentially have an eval executed within it.
1715 if (PL_cv_has_eval || PL_perldb) {
1717 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1718 if (cv != PL_compcv && CvCOMPILED(cv))
1719 break; /* no need to mark already-compiled code */
1721 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1722 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1729 /* extend namepad to match curpad */
1730 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1731 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1733 if (type == padtidy_SUBCLONE) {
1734 SV ** const namep = AvARRAY(PL_comppad_name);
1737 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1739 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1742 * The only things that a clonable function needs in its
1743 * pad are anonymous subs, constants and GVs.
1744 * The rest are created anew during cloning.
1746 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1747 || IS_PADGV(PL_curpad[ix]))
1750 if (!(PadnamePV(namesv) &&
1751 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1753 SvREFCNT_dec(PL_curpad[ix]);
1754 PL_curpad[ix] = NULL;
1758 else if (type == padtidy_SUB) {
1759 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1760 AV * const av = newAV(); /* Will be @_ */
1761 av_store(PL_comppad, 0, MUTABLE_SV(av));
1765 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1766 SV ** const namep = AvARRAY(PL_comppad_name);
1768 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1769 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1770 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1771 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1773 if (!SvPADMY(PL_curpad[ix])) {
1774 SvPADTMP_on(PL_curpad[ix]);
1775 } else if (!SvFAKE(namep[ix])) {
1776 /* This is a work around for how the current implementation of
1777 ?{ } blocks in regexps interacts with lexicals.
1779 One of our lexicals.
1780 Can't do this on all lexicals, otherwise sub baz() won't
1789 because completion of compiling &bar calling pad_tidy()
1790 would cause (top level) $foo to be marked as stale, and
1791 "no longer available". */
1792 SvPADSTALE_on(PL_curpad[ix]);
1796 PL_curpad = AvARRAY(PL_comppad);
1800 =for apidoc m|void|pad_free|PADOFFSET po
1802 Free the SV at offset po in the current pad.
1807 /* XXX DAPM integrate with pad_swipe ???? */
1809 Perl_pad_free(pTHX_ PADOFFSET po)
1812 ASSERT_CURPAD_LEGAL("pad_free");
1815 if (AvARRAY(PL_comppad) != PL_curpad)
1816 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1817 AvARRAY(PL_comppad), PL_curpad);
1819 Perl_croak(aTHX_ "panic: pad_free po");
1821 DEBUG_X(PerlIO_printf(Perl_debug_log,
1822 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1823 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1828 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1829 SvFLAGS(sv) &= ~SVs_PADTMP;
1831 if ((I32)po < PL_padix)
1836 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1838 Dump the contents of a padlist
1844 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1852 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1857 pad_name = *PadlistARRAY(padlist);
1858 pad = PadlistARRAY(padlist)[1];
1859 pname = AvARRAY(pad_name);
1860 ppad = AvARRAY(pad);
1861 Perl_dump_indent(aTHX_ level, file,
1862 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1863 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1866 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1867 const SV *namesv = pname[ix];
1868 if (namesv && !PadnameLEN(namesv)) {
1873 Perl_dump_indent(aTHX_ level+1, file,
1874 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1877 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1878 SvPVX_const(namesv),
1879 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1880 (unsigned long)PARENT_PAD_INDEX(namesv)
1884 Perl_dump_indent(aTHX_ level+1, file,
1885 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1888 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1889 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1890 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1895 Perl_dump_indent(aTHX_ level+1, file,
1896 "%2d. 0x%"UVxf"<%lu>\n",
1899 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1908 =for apidoc m|void|cv_dump|CV *cv|const char *title
1910 dump the contents of a CV
1916 S_cv_dump(pTHX_ const CV *cv, const char *title)
1918 const CV * const outside = CvOUTSIDE(cv);
1919 PADLIST* const padlist = CvPADLIST(cv);
1921 PERL_ARGS_ASSERT_CV_DUMP;
1923 PerlIO_printf(Perl_debug_log,
1924 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1927 (CvANON(cv) ? "ANON"
1928 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1929 : (cv == PL_main_cv) ? "MAIN"
1930 : CvUNIQUE(cv) ? "UNIQUE"
1931 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1934 : CvANON(outside) ? "ANON"
1935 : (outside == PL_main_cv) ? "MAIN"
1936 : CvUNIQUE(outside) ? "UNIQUE"
1937 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1939 PerlIO_printf(Perl_debug_log,
1940 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1941 do_dump_pad(1, Perl_debug_log, padlist, 1);
1944 #endif /* DEBUGGING */
1947 =for apidoc Am|CV *|cv_clone|CV *proto
1949 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1950 of the function: its code, pad structure, and other attributes.
1951 The prototype is combined with a capture of outer lexicals to which the
1952 code refers, which are taken from the currently-executing instance of
1953 the immediately surrounding code.
1958 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1961 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1964 PADLIST* const protopadlist = CvPADLIST(proto);
1965 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1966 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1967 SV** const pname = AvARRAY(protopad_name);
1968 SV** const ppad = AvARRAY(protopad);
1969 const I32 fname = AvFILLp(protopad_name);
1970 const I32 fpad = AvFILLp(protopad);
1973 bool subclones = FALSE;
1975 assert(!CvUNIQUE(proto));
1977 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1978 * reliable. The currently-running sub is always the one we need to
1980 * For my subs, the currently-running sub may not be the one we want.
1981 * We have to check whether it is a clone of CvOUTSIDE.
1982 * Note that in general for formats, CvOUTSIDE != find_runcv.
1983 * Since formats may be nested inside closures, CvOUTSIDE may point
1984 * to a prototype; we instead want the cloned parent who called us.
1988 if (CvWEAKOUTSIDE(proto))
1989 outside = find_runcv(NULL);
1991 outside = CvOUTSIDE(proto);
1992 if ((CvCLONE(outside) && ! CvCLONED(outside))
1993 || !CvPADLIST(outside)
1994 || PadlistNAMES(CvPADLIST(outside))
1995 != protopadlist->xpadl_outid) {
1996 outside = find_runcv_where(
1997 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1999 /* outside could be null */
2003 depth = outside ? CvDEPTH(outside) : 0;
2008 SAVESPTR(PL_compcv);
2010 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2013 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2015 SAVESPTR(PL_comppad_name);
2016 PL_comppad_name = protopad_name;
2017 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2019 av_fill(PL_comppad, fpad);
2021 PL_curpad = AvARRAY(PL_comppad);
2023 outpad = outside && CvPADLIST(outside)
2024 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2027 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2029 for (ix = fpad; ix > 0; ix--) {
2030 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2032 if (namesv && PadnameLEN(namesv)) { /* lexical */
2033 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2037 if (SvFAKE(namesv)) { /* lexical from outside? */
2038 /* formats may have an inactive, or even undefined, parent;
2039 but state vars are always available. */
2040 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2041 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2042 && (!outside || !CvDEPTH(outside))) ) {
2043 S_unavailable(aTHX_ namesv);
2047 SvREFCNT_inc_simple_void_NN(sv);
2050 const char sigil = SvPVX_const(namesv)[0];
2052 /* If there are state subs, we need to clone them, too.
2053 But they may need to close over variables we have
2054 not cloned yet. So we will have to do a second
2055 pass. Furthermore, there may be state subs clos-
2056 ing over other state subs’ entries, so we have
2057 to put a stub here and then clone into it on the
2059 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2060 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2062 sv = newSV_type(SVt_PVCV);
2064 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2067 /* Just provide a stub, but name it. It will be
2068 upgrade to the real thing on scope entry. */
2069 sv = newSV_type(SVt_PVCV);
2072 share_hek(SvPVX_const(namesv)+1,
2074 * (SvUTF8(namesv) ? -1 : 1),
2078 else sv = SvREFCNT_inc(ppad[ix]);
2079 else if (sigil == '@')
2080 sv = MUTABLE_SV(newAV());
2081 else if (sigil == '%')
2082 sv = MUTABLE_SV(newHV());
2086 /* reset the 'assign only once' flag on each state var */
2087 if (sigil != '&' && SvPAD_STATE(namesv))
2092 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2093 sv = SvREFCNT_inc_NN(ppad[ix]);
2103 for (ix = fpad; ix > 0; ix--) {
2104 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2105 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2106 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2107 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2110 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2115 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2120 const bool newcv = !cv;
2122 assert(!CvUNIQUE(proto));
2124 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2125 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2129 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2132 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2133 else CvGV_set(cv,CvGV(proto));
2134 CvSTASH_set(cv, CvSTASH(proto));
2136 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2138 CvSTART(cv) = CvSTART(proto);
2139 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2142 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2144 SvUTF8_on(MUTABLE_SV(cv));
2147 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2149 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2152 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2153 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2154 cv_dump(proto, "Proto");
2159 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2160 * The prototype was marked as a candiate for const-ization,
2161 * so try to grab the current const value, and if successful,
2162 * turn into a const sub:
2164 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2166 SvREFCNT_dec_NN(cv);
2167 /* For this calling case, op_const_sv returns a *copy*, which we
2168 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2169 Need to fix how lib/constant.pm works to eliminate this. */
2170 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2181 Perl_cv_clone(pTHX_ CV *proto)
2183 PERL_ARGS_ASSERT_CV_CLONE;
2185 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2186 return S_cv_clone(aTHX_ proto, NULL, NULL);
2189 /* Called only by pp_clonecv */
2191 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2193 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2195 return S_cv_clone(aTHX_ proto, target, NULL);
2199 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2201 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2202 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2203 moved to a pre-existing CV struct.
2209 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2212 AV * const comppad_name = PadlistARRAY(padlist)[0];
2213 AV * const comppad = PadlistARRAY(padlist)[1];
2214 SV ** const namepad = AvARRAY(comppad_name);
2215 SV ** const curpad = AvARRAY(comppad);
2217 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2218 PERL_UNUSED_ARG(old_cv);
2220 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2221 const SV * const namesv = namepad[ix];
2222 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2223 && *SvPVX_const(namesv) == '&')
2225 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2227 SvMAGICAL(curpad[ix])
2228 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2230 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2231 if (CvOUTSIDE(innercv) == old_cv) {
2232 if (!CvWEAKOUTSIDE(innercv)) {
2233 SvREFCNT_dec(old_cv);
2234 SvREFCNT_inc_simple_void_NN(new_cv);
2236 CvOUTSIDE(innercv) = new_cv;
2239 else { /* format reference */
2240 SV * const rv = curpad[ix];
2242 if (!SvOK(rv)) continue;
2244 assert(SvWEAKREF(rv));
2245 innercv = (CV *)SvRV(rv);
2246 assert(!CvWEAKOUTSIDE(innercv));
2247 SvREFCNT_dec(CvOUTSIDE(innercv));
2248 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2255 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2257 Push a new pad frame onto the padlist, unless there's already a pad at
2258 this depth, in which case don't bother creating a new one. Then give
2259 the new pad an @_ in slot zero.
2265 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2267 PERL_ARGS_ASSERT_PAD_PUSH;
2269 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2270 PAD** const svp = PadlistARRAY(padlist);
2271 AV* const newpad = newAV();
2272 SV** const oldpad = AvARRAY(svp[depth-1]);
2273 I32 ix = AvFILLp((const AV *)svp[1]);
2274 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2275 SV** const names = AvARRAY(svp[0]);
2278 for ( ;ix > 0; ix--) {
2279 if (names_fill >= ix && PadnameLEN(names[ix])) {
2280 const char sigil = SvPVX_const(names[ix])[0];
2281 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2282 || (SvFLAGS(names[ix]) & SVpad_STATE)
2285 /* outer lexical or anon code */
2286 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2288 else { /* our own lexical */
2291 sv = MUTABLE_SV(newAV());
2292 else if (sigil == '%')
2293 sv = MUTABLE_SV(newHV());
2296 av_store(newpad, ix, sv);
2300 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2301 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2304 /* save temporaries on recursion? */
2305 SV * const sv = newSV(0);
2306 av_store(newpad, ix, sv);
2311 av_store(newpad, 0, MUTABLE_SV(av));
2314 padlist_store(padlist, depth, newpad);
2319 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2321 Looks up the type of the lexical variable at position I<po> in the
2322 currently-compiling pad. If the variable is typed, the stash of the
2323 class to which it is typed is returned. If not, C<NULL> is returned.
2329 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2331 SV* const av = PAD_COMPNAME_SV(po);
2332 if ( SvPAD_TYPED(av) ) {
2338 #if defined(USE_ITHREADS)
2340 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2343 =for apidoc padlist_dup
2351 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2357 PERL_ARGS_ASSERT_PADLIST_DUP;
2362 cloneall = param->flags & CLONEf_COPY_STACKS
2363 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2364 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2366 max = cloneall ? PadlistMAX(srcpad) : 1;
2368 Newx(dstpad, 1, PADLIST);
2369 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2370 PadlistMAX(dstpad) = max;
2371 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2375 for (depth = 0; depth <= max; ++depth)
2376 PadlistARRAY(dstpad)[depth] =
2377 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2379 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2380 to build anything other than the first level of pads. */
2381 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2383 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2384 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2385 SV **oldpad = AvARRAY(srcpad1);
2390 PadlistARRAY(dstpad)[0] =
2391 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2392 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2396 av_extend(pad1, ix);
2397 PadlistARRAY(dstpad)[1] = pad1;
2398 pad1a = AvARRAY(pad1);
2403 for ( ;ix > 0; ix--) {
2406 } else if (names_fill >= ix && names[ix] &&
2407 PadnameLEN(names[ix])) {
2408 const char sigil = SvPVX_const(names[ix])[0];
2409 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2410 || (SvFLAGS(names[ix]) & SVpad_STATE)
2413 /* outer lexical or anon code */
2414 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2416 else { /* our own lexical */
2417 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2418 /* This is a work around for how the current
2419 implementation of ?{ } blocks in regexps
2420 interacts with lexicals. */
2421 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2426 sv = MUTABLE_SV(newAV());
2427 else if (sigil == '%')
2428 sv = MUTABLE_SV(newHV());
2436 else if (IS_PADGV(oldpad[ix])
2437 || ( names_fill >= ix && names[ix]
2438 && PadnamePV(names[ix]) )) {
2439 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2442 /* save temporaries on recursion? */
2443 SV * const sv = newSV(0);
2446 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2447 FIXTHAT before merging this branch.
2448 (And I know how to) */
2449 if (SvPADMY(oldpad[ix]))
2457 args = newAV(); /* Will be @_ */
2459 pad1a[0] = (SV *)args;
2467 #endif /* USE_ITHREADS */
2470 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2473 SSize_t const oldmax = PadlistMAX(padlist);
2475 PERL_ARGS_ASSERT_PADLIST_STORE;
2479 if (key > PadlistMAX(padlist)) {
2480 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2481 (SV ***)&PadlistARRAY(padlist),
2482 (SV ***)&PadlistARRAY(padlist));
2483 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2486 ary = PadlistARRAY(padlist);
2487 SvREFCNT_dec(ary[key]);
2494 * c-indentation-style: bsd
2496 * indent-tabs-mode: nil
2499 * ex: set ts=8 sts=4 sw=4 et: