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 an AV. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "forms" 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 CvPADLIST AV has the REFCNT of its component items managed "manually"
46 (mostly in pad.c) rather than by normal av.c rules. So we turn off AvREAL
47 just before freeing it, to let av.c know not to touch the entries.
48 The items in the AV are not SVs as for a normal AV, but other AVs:
50 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
51 the "static type information" for lexicals.
53 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
54 depth of recursion into the CV.
55 The 0'th slot of a frame AV is an AV which is @_.
56 other entries are storage for variables and op targets.
58 Iterating over the names AV iterates over all possible pad
59 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
62 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time. These don't have names by which they
65 can be looked up from Perl code at run time through eval"" like
66 my/our variables can be. Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH). During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
76 COP_SEQ_RANGE_LOW _HIGH
77 ----------------- -----
78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
80 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected). SvUVX is
86 sometimes hijacked to store the generation number during compilation.
88 If SvFAKE is set on the name SV, then that slot in the frame AV is
89 a REFCNT'ed reference to a lexical from "outside". In this case,
90 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
91 in scope throughout. Instead xhigh stores some flags containing info about
92 the real lexical (is it declared in an anon, and is it capable of being
93 instantiated multiple times?), and for fake ANONs, xlow contains the index
94 within the parent's pad where the lexical's value is stored, to make
97 If the 'name' is '&' the corresponding entry in frame AV
98 is a CV representing a possible closure.
99 (SvFAKE and name of '&' is not a meaningful combination currently but could
100 become so if C<my sub foo {}> is implemented.)
102 Note that formats are treated as anon subs, and are cloned each time
103 write is called (if necessary).
105 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
106 and set on scope exit. This allows the 'Variable $x is not available' warning
107 to be generated in evals, such as
109 { my $x = 1; sub f { eval '$x'} } f();
111 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
113 =for apidoc AmxU|AV *|PL_comppad_name
115 During compilation, this points to the array containing the names part
116 of the pad for the currently-compiling code.
118 =for apidoc AmxU|AV *|PL_comppad
120 During compilation, this points to the array containing the values
121 part of the pad for the currently-compiling code. (At runtime a CV may
122 have many such value arrays; at compile time just one is constructed.)
123 At runtime, this points to the array containing the currently-relevant
124 values for the pad for the currently-executing code.
126 =for apidoc AmxU|SV **|PL_curpad
128 Points directly to the body of the L</PL_comppad> array.
129 (I.e., this is C<AvARRAY(PL_comppad)>.)
136 #define PERL_IN_PAD_C
138 #include "keywords.h"
140 #define COP_SEQ_RANGE_LOW_set(sv,val) \
141 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
142 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
143 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
145 #define PARENT_PAD_INDEX_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
151 =for apidoc mx|void|pad_peg|const char *s
153 When PERL_MAD is enabled, this is a small no-op function that gets called
154 at the start of each pad-related function. It can be breakpointed to
155 track all pad operations. The parameter is a string indicating the type
156 of pad operation being performed.
162 void pad_peg(const char* s) {
163 static int pegcnt; /* XXX not threadsafe */
166 PERL_ARGS_ASSERT_PAD_PEG;
173 This is basically sv_eq_flags() in sv.c, but we avoid the magic
178 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
179 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
180 const char *pv1 = SvPVX_const(sv);
181 STRLEN cur1 = SvCUR(sv);
182 const char *pv2 = pv;
187 svrecode = newSVpvn(pv2, cur2);
188 sv_recode_to_utf8(svrecode, PL_encoding);
189 pv2 = SvPV_const(svrecode, cur2);
192 svrecode = newSVpvn(pv1, cur1);
193 sv_recode_to_utf8(svrecode, PL_encoding);
194 pv1 = SvPV_const(svrecode, cur1);
196 SvREFCNT_dec(svrecode);
198 if (flags & SVf_UTF8)
199 return (bytes_cmp_utf8(
200 (const U8*)pv1, cur1,
201 (const U8*)pv2, cur2) == 0);
203 return (bytes_cmp_utf8(
204 (const U8*)pv2, cur2,
205 (const U8*)pv1, cur1) == 0);
208 return ((SvPVX_const(sv) == pv)
209 || memEQ(SvPVX_const(sv), pv, pvlen));
214 =for apidoc Am|PADLIST *|pad_new|int flags
216 Create a new padlist, updating the global variables for the
217 currently-compiling padlist to point to the new padlist. The following
218 flags can be OR'ed together:
220 padnew_CLONE this pad is for a cloned CV
221 padnew_SAVE save old globals on the save stack
222 padnew_SAVESUB also save extra stuff for start of sub
228 Perl_pad_new(pTHX_ int flags)
231 AV *padlist, *padname, *pad;
234 ASSERT_CURPAD_LEGAL("pad_new");
236 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
237 * vars (based on flags) rather than storing vals + addresses for
238 * each individually. Also see pad_block_start.
239 * XXX DAPM Try to see whether all these conditionals are required
242 /* save existing state, ... */
244 if (flags & padnew_SAVE) {
246 SAVESPTR(PL_comppad_name);
247 if (! (flags & padnew_CLONE)) {
249 SAVEI32(PL_comppad_name_fill);
250 SAVEI32(PL_min_intro_pending);
251 SAVEI32(PL_max_intro_pending);
252 SAVEBOOL(PL_cv_has_eval);
253 if (flags & padnew_SAVESUB) {
254 SAVEBOOL(PL_pad_reset_pending);
258 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
259 * saved - check at some pt that this is okay */
261 /* ... create new pad ... */
267 if (flags & padnew_CLONE) {
268 /* XXX DAPM I dont know why cv_clone needs it
269 * doing differently yet - perhaps this separate branch can be
270 * dispensed with eventually ???
273 AV * const a0 = newAV(); /* will be @_ */
274 av_store(pad, 0, MUTABLE_SV(a0));
278 av_store(pad, 0, NULL);
281 /* Most subroutines never recurse, hence only need 2 entries in the padlist
282 array - names, and depth=1. The default for av_store() is to allocate
283 0..3, and even an explicit call to av_extend() with <3 will be rounded
284 up, so we inline the allocation of the array here. */
286 AvFILLp(padlist) = 1;
288 AvALLOC(padlist) = ary;
289 AvARRAY(padlist) = ary;
290 ary[0] = MUTABLE_SV(padname);
291 ary[1] = MUTABLE_SV(pad);
293 /* ... then update state variables */
295 PL_comppad_name = padname;
297 PL_curpad = AvARRAY(pad);
299 if (! (flags & padnew_CLONE)) {
300 PL_comppad_name_fill = 0;
301 PL_min_intro_pending = 0;
306 DEBUG_X(PerlIO_printf(Perl_debug_log,
307 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
308 " name=0x%"UVxf" flags=0x%"UVxf"\n",
309 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
310 PTR2UV(padname), (UV)flags
314 return (PADLIST*)padlist;
319 =head1 Embedding Functions
323 Clear out all the active components of a CV. This can happen either
324 by an explicit C<undef &foo>, or by the reference count going to zero.
325 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
326 children can still follow the full lexical scope chain.
332 Perl_cv_undef(pTHX_ CV *cv)
335 const PADLIST *padlist = CvPADLIST(cv);
337 PERL_ARGS_ASSERT_CV_UNDEF;
339 DEBUG_X(PerlIO_printf(Perl_debug_log,
340 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
341 PTR2UV(cv), PTR2UV(PL_comppad))
344 if (CvFILE(cv) && CvDYNFILE(cv)) {
345 Safefree(CvFILE(cv));
349 if (!CvISXSUB(cv) && CvROOT(cv)) {
350 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
351 Perl_croak(aTHX_ "Can't undef active subroutine");
354 PAD_SAVE_SETNULLPAD();
361 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
364 /* This statement and the subsequence if block was pad_undef(). */
365 pad_peg("pad_undef");
367 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
371 /* Free the padlist associated with a CV.
372 If parts of it happen to be current, we null the relevant PL_*pad*
373 global vars so that we don't have any dangling references left.
374 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
375 subs to the outer of this cv. */
377 DEBUG_X(PerlIO_printf(Perl_debug_log,
378 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
379 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
382 /* detach any '&' anon children in the pad; if afterwards they
383 * are still live, fix up their CvOUTSIDEs to point to our outside,
385 /* XXX DAPM for efficiency, we should only do this if we know we have
386 * children, or integrate this loop with general cleanup */
388 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
389 CV * const outercv = CvOUTSIDE(cv);
390 const U32 seq = CvOUTSIDE_SEQ(cv);
391 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
392 SV ** const namepad = AvARRAY(comppad_name);
393 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
394 SV ** const curpad = AvARRAY(comppad);
395 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
396 SV * const namesv = namepad[ix];
397 if (namesv && namesv != &PL_sv_undef
398 && *SvPVX_const(namesv) == '&')
400 CV * const innercv = MUTABLE_CV(curpad[ix]);
401 U32 inner_rc = SvREFCNT(innercv);
404 SvREFCNT_dec(namesv);
406 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
408 SvREFCNT_dec(innercv);
412 /* in use, not just a prototype */
413 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
414 assert(CvWEAKOUTSIDE(innercv));
415 /* don't relink to grandfather if he's being freed */
416 if (outercv && SvREFCNT(outercv)) {
417 CvWEAKOUTSIDE_off(innercv);
418 CvOUTSIDE(innercv) = outercv;
419 CvOUTSIDE_SEQ(innercv) = seq;
420 SvREFCNT_inc_simple_void_NN(outercv);
423 CvOUTSIDE(innercv) = NULL;
430 ix = AvFILLp(padlist);
432 SV* const sv = AvARRAY(padlist)[ix--];
434 if (sv == (const SV *)PL_comppad) {
442 SV *const sv = AvARRAY(padlist)[0];
443 if (sv == (const SV *)PL_comppad_name)
444 PL_comppad_name = NULL;
447 AvREAL_off(CvPADLIST(cv));
448 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
449 CvPADLIST(cv) = NULL;
453 /* remove CvOUTSIDE unless this is an undef rather than a free */
454 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
455 if (!CvWEAKOUTSIDE(cv))
456 SvREFCNT_dec(CvOUTSIDE(cv));
457 CvOUTSIDE(cv) = NULL;
460 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
463 if (CvISXSUB(cv) && CvXSUB(cv)) {
466 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
467 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
468 * to choose an error message */
469 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
473 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
475 Allocates a place in the currently-compiling
476 pad (via L<perlapi/pad_alloc>) and
477 then stores a name for that entry. I<namesv> is adopted and becomes the
478 name entry; it must already contain the name string and be sufficiently
479 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
480 added to I<namesv>. None of the other
481 processing of L<perlapi/pad_add_name_pvn>
482 is done. Returns the offset of the allocated pad slot.
488 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
491 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
493 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
495 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
498 assert(SvTYPE(namesv) == SVt_PVMG);
499 SvPAD_TYPED_on(namesv);
500 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
503 SvPAD_OUR_on(namesv);
504 SvOURSTASH_set(namesv, ourstash);
505 SvREFCNT_inc_simple_void_NN(ourstash);
507 else if (flags & padadd_STATE) {
508 SvPAD_STATE_on(namesv);
511 av_store(PL_comppad_name, offset, namesv);
516 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
518 Allocates a place in the currently-compiling pad for a named lexical
519 variable. Stores the name and other metadata in the name part of the
520 pad, and makes preparations to manage the variable's lexical scoping.
521 Returns the offset of the allocated pad slot.
523 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
524 If I<typestash> is non-null, the name is for a typed lexical, and this
525 identifies the type. If I<ourstash> is non-null, it's a lexical reference
526 to a package variable, and this identifies the package. The following
527 flags can be OR'ed together:
529 padadd_OUR redundantly specifies if it's a package var
530 padadd_STATE variable will retain value persistently
531 padadd_NO_DUP_CHECK skip check for lexical shadowing
537 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
538 U32 flags, HV *typestash, HV *ourstash)
545 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
547 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
548 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
551 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
553 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
554 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
557 sv_setpvn(namesv, namepv, namelen);
560 flags |= padadd_UTF8_NAME;
564 flags &= ~padadd_UTF8_NAME;
566 if ((flags & padadd_NO_DUP_CHECK) == 0) {
567 /* check for duplicate declaration */
568 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
571 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
573 /* not yet introduced */
574 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
575 COP_SEQ_RANGE_HIGH_set(namesv, 0);
577 if (!PL_min_intro_pending)
578 PL_min_intro_pending = offset;
579 PL_max_intro_pending = offset;
580 /* if it's not a simple scalar, replace with an AV or HV */
581 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
582 assert(SvREFCNT(PL_curpad[offset]) == 1);
583 if (namelen != 0 && *namepv == '@')
584 sv_upgrade(PL_curpad[offset], SVt_PVAV);
585 else if (namelen != 0 && *namepv == '%')
586 sv_upgrade(PL_curpad[offset], SVt_PVHV);
587 assert(SvPADMY(PL_curpad[offset]));
588 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
589 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
590 (long)offset, SvPVX(namesv),
591 PTR2UV(PL_curpad[offset])));
597 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
599 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
600 instead of a string/length pair.
606 Perl_pad_add_name_pv(pTHX_ const char *name,
607 const U32 flags, HV *typestash, HV *ourstash)
609 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
610 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
614 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
616 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
617 of an SV instead of a string/length pair.
623 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
627 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
628 namepv = SvPV(name, namelen);
630 flags |= padadd_UTF8_NAME;
631 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
635 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
637 Allocates a place in the currently-compiling pad,
638 returning the offset of the allocated pad slot.
639 No name is initially attached to the pad slot.
640 I<tmptype> is a set of flags indicating the kind of pad entry required,
641 which will be set in the value SV for the allocated pad entry:
643 SVs_PADMY named lexical variable ("my", "our", "state")
644 SVs_PADTMP unnamed temporary store
646 I<optype> should be an opcode indicating the type of operation that the
647 pad entry is to support. This doesn't affect operational semantics,
648 but is used for debugging.
653 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
654 * or at least rationalise ??? */
655 /* And flag whether the incoming name is UTF8 or 8 bit?
656 Could do this either with the +ve/-ve hack of the HV code, or expanding
657 the flag bits. Either way, this makes proper Unicode safe pad support.
662 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
668 PERL_UNUSED_ARG(optype);
669 ASSERT_CURPAD_ACTIVE("pad_alloc");
671 if (AvARRAY(PL_comppad) != PL_curpad)
672 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
673 AvARRAY(PL_comppad), PL_curpad);
674 if (PL_pad_reset_pending)
676 if (tmptype & SVs_PADMY) {
677 /* For a my, simply push a null SV onto the end of PL_comppad. */
678 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
679 retval = AvFILLp(PL_comppad);
682 /* For a tmp, scan the pad from PL_padix upwards
683 * for a slot which has no name and no active value.
685 SV * const * const names = AvARRAY(PL_comppad_name);
686 const SSize_t names_fill = AvFILLp(PL_comppad_name);
689 * "foreach" index vars temporarily become aliases to non-"my"
690 * values. Thus we must skip, not just pad values that are
691 * marked as current pad values, but also those with names.
693 /* HVDS why copy to sv here? we don't seem to use it */
694 if (++PL_padix <= names_fill &&
695 (sv = names[PL_padix]) && sv != &PL_sv_undef)
697 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
698 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
699 !IS_PADGV(sv) && !IS_PADCONST(sv))
704 SvFLAGS(sv) |= tmptype;
705 PL_curpad = AvARRAY(PL_comppad);
707 DEBUG_X(PerlIO_printf(Perl_debug_log,
708 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
709 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
710 PL_op_name[optype]));
711 #ifdef DEBUG_LEAKING_SCALARS
712 sv->sv_debug_optype = optype;
713 sv->sv_debug_inpad = 1;
715 return (PADOFFSET)retval;
719 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
721 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
722 for an anonymous function that is lexically scoped inside the
723 currently-compiling function.
724 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
725 to the outer scope is weakened to avoid a reference loop.
727 I<optype> should be an opcode indicating the type of operation that the
728 pad entry is to support. This doesn't affect operational semantics,
729 but is used for debugging.
735 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
739 SV* const name = newSV_type(SVt_PVNV);
741 PERL_ARGS_ASSERT_PAD_ADD_ANON;
744 sv_setpvs(name, "&");
745 /* These two aren't used; just make sure they're not equal to
746 * PERL_PADSEQ_INTRO */
747 COP_SEQ_RANGE_LOW_set(name, 0);
748 COP_SEQ_RANGE_HIGH_set(name, 0);
749 ix = pad_alloc(optype, SVs_PADMY);
750 av_store(PL_comppad_name, ix, name);
751 /* XXX DAPM use PL_curpad[] ? */
752 av_store(PL_comppad, ix, (SV*)func);
753 SvPADMY_on((SV*)func);
755 /* to avoid ref loops, we never have parent + child referencing each
756 * other simultaneously */
757 if (CvOUTSIDE(func)) {
758 assert(!CvWEAKOUTSIDE(func));
759 CvWEAKOUTSIDE_on(func);
760 SvREFCNT_dec(CvOUTSIDE(func));
766 =for apidoc pad_check_dup
768 Check for duplicate declarations: report any of:
770 * a my in the current scope with the same name;
771 * an our (anywhere in the pad) with the same name and the
772 same stash as C<ourstash>
774 C<is_our> indicates that the name to check is an 'our' declaration.
780 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
785 const U32 is_our = flags & padadd_OUR;
787 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
789 ASSERT_CURPAD_ACTIVE("pad_check_dup");
791 assert((flags & ~padadd_OUR) == 0);
793 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
794 return; /* nothing to check */
796 svp = AvARRAY(PL_comppad_name);
797 top = AvFILLp(PL_comppad_name);
798 /* check the current scope */
799 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
801 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
802 SV * const sv = svp[off];
804 && sv != &PL_sv_undef
806 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
807 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
810 if (is_our && (SvPAD_OUR(sv)))
811 break; /* "our" masking "our" */
812 Perl_warner(aTHX_ packWARN(WARN_MISC),
813 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
814 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
816 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
817 ? "scope" : "statement"));
822 /* check the rest of the pad */
825 SV * const sv = svp[off];
827 && sv != &PL_sv_undef
829 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
830 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
831 && SvOURSTASH(sv) == ourstash
834 Perl_warner(aTHX_ packWARN(WARN_MISC),
835 "\"our\" variable %"SVf" redeclared", sv);
836 if ((I32)off <= PL_comppad_name_floor)
837 Perl_warner(aTHX_ packWARN(WARN_MISC),
838 "\t(Did you mean \"local\" instead of \"our\"?)\n");
848 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
850 Given the name of a lexical variable, find its position in the
851 currently-compiling pad.
852 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
853 I<flags> is reserved and must be zero.
854 If it is not in the current pad but appears in the pad of any lexically
855 enclosing scope, then a pseudo-entry for it is added in the current pad.
856 Returns the offset in the current pad,
857 or C<NOT_IN_PAD> if no such lexical is in scope.
863 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
872 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
874 pad_peg("pad_findmy_pvn");
876 if (flags & ~padadd_UTF8_NAME)
877 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
880 if (flags & padadd_UTF8_NAME) {
882 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
885 flags |= padadd_UTF8_NAME;
887 flags &= ~padadd_UTF8_NAME;
890 offset = pad_findlex(namepv, namelen, flags,
891 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
892 if ((PADOFFSET)offset != NOT_IN_PAD)
895 /* look for an our that's being introduced; this allows
896 * our $foo = 0 unless defined $foo;
897 * to not give a warning. (Yes, this is a hack) */
899 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
900 name_svp = AvARRAY(nameav);
901 for (offset = AvFILLp(nameav); offset > 0; offset--) {
902 const SV * const namesv = name_svp[offset];
903 if (namesv && namesv != &PL_sv_undef
905 && (SvPAD_OUR(namesv))
906 && SvCUR(namesv) == namelen
907 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
908 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
909 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
917 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
919 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
920 instead of a string/length pair.
926 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
928 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
929 return pad_findmy_pvn(name, strlen(name), flags);
933 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
935 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
936 of an SV instead of a string/length pair.
942 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
946 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
947 namepv = SvPV(name, namelen);
949 flags |= padadd_UTF8_NAME;
950 return pad_findmy_pvn(namepv, namelen, flags);
954 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
956 Find the position of the lexical C<$_> in the pad of the
957 currently-executing function. Returns the offset in the current pad,
958 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
959 the global one should be used instead).
960 L</find_rundefsv> is likely to be more convenient.
966 Perl_find_rundefsvoffset(pTHX)
971 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
972 NULL, &out_sv, &out_flags);
976 =for apidoc Am|SV *|find_rundefsv
978 Find and return the variable that is named C<$_> in the lexical scope
979 of the currently-executing function. This may be a lexical C<$_>,
980 or will otherwise be the global one.
986 Perl_find_rundefsv(pTHX)
992 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
993 NULL, &namesv, &flags);
995 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1002 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1008 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1010 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1011 NULL, &namesv, &flags);
1013 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1016 return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1020 =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
1022 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1023 in the inner pads if it's found in an outer one.
1025 Returns the offset in the bottom pad of the lex or the fake lex.
1026 cv is the CV in which to start the search, and seq is the current cop_seq
1027 to match against. If warn is true, print appropriate warnings. The out_*
1028 vars return values, and so are pointers to where the returned values
1029 should be stored. out_capture, if non-null, requests that the innermost
1030 instance of the lexical is captured; out_name_sv is set to the innermost
1031 matched namesv or fake namesv; out_flags returns the flags normally
1032 associated with the IVX field of a fake namesv.
1034 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1035 then comes back down, adding fake entries as it goes. It has to be this way
1036 because fake namesvs in anon protoypes have to store in xlow the index into
1042 /* the CV has finished being compiled. This is not a sufficient test for
1043 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1044 #define CvCOMPILED(cv) CvROOT(cv)
1046 /* the CV does late binding of its lexicals */
1047 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1051 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1052 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1055 I32 offset, new_offset;
1058 const AV * const padlist = CvPADLIST(cv);
1060 PERL_ARGS_ASSERT_PAD_FINDLEX;
1062 if (flags & ~padadd_UTF8_NAME)
1063 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1068 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1069 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1070 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1071 out_capture ? " capturing" : "" ));
1073 /* first, search this pad */
1075 if (padlist) { /* not an undef CV */
1076 I32 fake_offset = 0;
1077 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1078 SV * const * const name_svp = AvARRAY(nameav);
1080 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1081 const SV * const namesv = name_svp[offset];
1082 if (namesv && namesv != &PL_sv_undef
1083 && SvCUR(namesv) == namelen
1084 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1085 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1087 if (SvFAKE(namesv)) {
1088 fake_offset = offset; /* in case we don't find a real one */
1091 /* is seq within the range _LOW to _HIGH ?
1092 * This is complicated by the fact that PL_cop_seqmax
1093 * may have wrapped around at some point */
1094 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1095 continue; /* not yet introduced */
1097 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1098 /* in compiling scope */
1100 (seq > COP_SEQ_RANGE_LOW(namesv))
1101 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1102 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1107 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1109 ( seq > COP_SEQ_RANGE_LOW(namesv)
1110 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1112 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1113 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1119 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1120 if (offset > 0) { /* not fake */
1122 *out_name_sv = name_svp[offset]; /* return the namesv */
1124 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1125 * instances. For now, we just test !CvUNIQUE(cv), but
1126 * ideally, we should detect my's declared within loops
1127 * etc - this would allow a wider range of 'not stayed
1128 * shared' warnings. We also treated already-compiled
1129 * lexes as not multi as viewed from evals. */
1131 *out_flags = CvANON(cv) ?
1133 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1134 ? PAD_FAKELEX_MULTI : 0;
1136 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1137 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1138 PTR2UV(cv), (long)offset,
1139 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1140 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1142 else { /* fake match */
1143 offset = fake_offset;
1144 *out_name_sv = name_svp[offset]; /* return the namesv */
1145 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1146 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1147 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1148 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1149 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1153 /* return the lex? */
1158 if (SvPAD_OUR(*out_name_sv)) {
1159 *out_capture = NULL;
1163 /* trying to capture from an anon prototype? */
1165 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1166 : *out_flags & PAD_FAKELEX_ANON)
1169 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1170 "Variable \"%"SVf"\" is not available",
1171 newSVpvn_flags(namepv, namelen,
1173 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1175 *out_capture = NULL;
1181 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1182 && !SvPAD_STATE(name_svp[offset])
1183 && warn && ckWARN(WARN_CLOSURE)) {
1185 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1186 "Variable \"%"SVf"\" will not stay shared",
1187 newSVpvn_flags(namepv, namelen,
1189 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1192 if (fake_offset && CvANON(cv)
1193 && CvCLONE(cv) &&!CvCLONED(cv))
1196 /* not yet caught - look further up */
1197 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1198 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1201 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1203 newwarn, out_capture, out_name_sv, out_flags);
1208 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1209 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1210 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1211 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1212 PTR2UV(cv), PTR2UV(*out_capture)));
1214 if (SvPADSTALE(*out_capture)
1215 && !SvPAD_STATE(name_svp[offset]))
1217 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1218 "Variable \"%"SVf"\" is not available",
1219 newSVpvn_flags(namepv, namelen,
1221 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1222 *out_capture = NULL;
1225 if (!*out_capture) {
1226 if (namelen != 0 && *namepv == '@')
1227 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1228 else if (namelen != 0 && *namepv == '%')
1229 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1231 *out_capture = sv_newmortal();
1239 /* it's not in this pad - try above */
1244 /* out_capture non-null means caller wants us to capture lex; in
1245 * addition we capture ourselves unless it's an ANON/format */
1246 new_capturep = out_capture ? out_capture :
1247 CvLATE(cv) ? NULL : &new_capture;
1249 offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1250 new_capturep, out_name_sv, out_flags);
1251 if ((PADOFFSET)offset == NOT_IN_PAD)
1254 /* found in an outer CV. Add appropriate fake entry to this pad */
1256 /* don't add new fake entries (via eval) to CVs that we have already
1257 * finished compiling, or to undef CVs */
1258 if (CvCOMPILED(cv) || !padlist)
1259 return 0; /* this dummy (and invalid) value isnt used by the caller */
1262 /* This relies on sv_setsv_flags() upgrading the destination to the same
1263 type as the source, independent of the flags set, and on it being
1264 "good" and only copying flag bits and pointers that it understands.
1266 SV *new_namesv = newSVsv(*out_name_sv);
1267 AV * const ocomppad_name = PL_comppad_name;
1268 PAD * const ocomppad = PL_comppad;
1269 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1270 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1271 PL_curpad = AvARRAY(PL_comppad);
1274 = pad_alloc_name(new_namesv,
1275 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1276 SvPAD_TYPED(*out_name_sv)
1277 ? SvSTASH(*out_name_sv) : NULL,
1278 SvOURSTASH(*out_name_sv)
1281 SvFAKE_on(new_namesv);
1282 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1283 "Pad addname: %ld \"%.*s\" FAKE\n",
1285 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1286 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1288 PARENT_PAD_INDEX_set(new_namesv, 0);
1289 if (SvPAD_OUR(new_namesv)) {
1290 NOOP; /* do nothing */
1292 else if (CvLATE(cv)) {
1293 /* delayed creation - just note the offset within parent pad */
1294 PARENT_PAD_INDEX_set(new_namesv, offset);
1298 /* immediate creation - capture outer value right now */
1299 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1300 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1301 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1302 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1304 *out_name_sv = new_namesv;
1305 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1307 PL_comppad_name = ocomppad_name;
1308 PL_comppad = ocomppad;
1309 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1317 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1319 Get the value at offset I<po> in the current (compiling or executing) pad.
1320 Use macro PAD_SV instead of calling this function directly.
1326 Perl_pad_sv(pTHX_ PADOFFSET po)
1329 ASSERT_CURPAD_ACTIVE("pad_sv");
1332 Perl_croak(aTHX_ "panic: pad_sv po");
1333 DEBUG_X(PerlIO_printf(Perl_debug_log,
1334 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1335 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1337 return PL_curpad[po];
1341 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1343 Set the value at offset I<po> in the current (compiling or executing) pad.
1344 Use the macro PAD_SETSV() rather than calling this function directly.
1350 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1354 PERL_ARGS_ASSERT_PAD_SETSV;
1356 ASSERT_CURPAD_ACTIVE("pad_setsv");
1358 DEBUG_X(PerlIO_printf(Perl_debug_log,
1359 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1360 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1365 #endif /* DEBUGGING */
1368 =for apidoc m|void|pad_block_start|int full
1370 Update the pad compilation state variables on entry to a new block
1375 /* XXX DAPM perhaps:
1376 * - integrate this in general state-saving routine ???
1377 * - combine with the state-saving going on in pad_new ???
1378 * - introduce a new SAVE type that does all this in one go ?
1382 Perl_pad_block_start(pTHX_ int full)
1385 ASSERT_CURPAD_ACTIVE("pad_block_start");
1386 SAVEI32(PL_comppad_name_floor);
1387 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1389 PL_comppad_name_fill = PL_comppad_name_floor;
1390 if (PL_comppad_name_floor < 0)
1391 PL_comppad_name_floor = 0;
1392 SAVEI32(PL_min_intro_pending);
1393 SAVEI32(PL_max_intro_pending);
1394 PL_min_intro_pending = 0;
1395 SAVEI32(PL_comppad_name_fill);
1396 SAVEI32(PL_padix_floor);
1397 PL_padix_floor = PL_padix;
1398 PL_pad_reset_pending = FALSE;
1402 =for apidoc m|U32|intro_my
1404 "Introduce" my variables to visible status.
1417 ASSERT_CURPAD_ACTIVE("intro_my");
1418 if (! PL_min_intro_pending)
1419 return PL_cop_seqmax;
1421 svp = AvARRAY(PL_comppad_name);
1422 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1423 SV * const sv = svp[i];
1425 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1426 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1428 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1429 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1430 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1431 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1432 (long)i, SvPVX_const(sv),
1433 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1434 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1438 seq = PL_cop_seqmax;
1440 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1442 PL_min_intro_pending = 0;
1443 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1444 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1445 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1451 =for apidoc m|void|pad_leavemy
1453 Cleanup at end of scope during compilation: set the max seq number for
1454 lexicals in this scope and warn of any lexicals that never got introduced.
1460 Perl_pad_leavemy(pTHX)
1464 SV * const * const svp = AvARRAY(PL_comppad_name);
1466 PL_pad_reset_pending = FALSE;
1468 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1469 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1470 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1471 const SV * const sv = svp[off];
1472 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1473 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1474 "%"SVf" never introduced",
1478 /* "Deintroduce" my variables that are leaving with this scope. */
1479 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1480 const SV * const sv = svp[off];
1481 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1482 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1484 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1485 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1486 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1487 (long)off, SvPVX_const(sv),
1488 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1489 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1494 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1496 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1497 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1501 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1503 Abandon the tmp in the current pad at offset po and replace with a
1510 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1513 ASSERT_CURPAD_LEGAL("pad_swipe");
1516 if (AvARRAY(PL_comppad) != PL_curpad)
1517 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1518 AvARRAY(PL_comppad), PL_curpad);
1519 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1520 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1521 (long)po, (long)AvFILLp(PL_comppad));
1523 DEBUG_X(PerlIO_printf(Perl_debug_log,
1524 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1525 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1528 SvPADTMP_off(PL_curpad[po]);
1530 SvREFCNT_dec(PL_curpad[po]);
1533 /* if pad tmps aren't shared between ops, then there's no need to
1534 * create a new tmp when an existing op is freed */
1535 #ifdef USE_BROKEN_PAD_RESET
1536 PL_curpad[po] = newSV(0);
1537 SvPADTMP_on(PL_curpad[po]);
1539 PL_curpad[po] = &PL_sv_undef;
1541 if ((I32)po < PL_padix)
1546 =for apidoc m|void|pad_reset
1548 Mark all the current temporaries for reuse
1553 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1554 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1555 * on the stack by OPs that use them, there are several ways to get an alias
1556 * to a shared TARG. Such an alias will change randomly and unpredictably.
1557 * We avoid doing this until we can think of a Better Way.
1563 #ifdef USE_BROKEN_PAD_RESET
1564 if (AvARRAY(PL_comppad) != PL_curpad)
1565 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1566 AvARRAY(PL_comppad), PL_curpad);
1568 DEBUG_X(PerlIO_printf(Perl_debug_log,
1569 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1570 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1571 (long)PL_padix, (long)PL_padix_floor
1575 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1577 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1578 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1579 SvPADTMP_off(PL_curpad[po]);
1581 PL_padix = PL_padix_floor;
1584 PL_pad_reset_pending = FALSE;
1588 =for apidoc Amx|void|pad_tidy|padtidy_type type
1590 Tidy up a pad at the end of compilation of the code to which it belongs.
1591 Jobs performed here are: remove most stuff from the pads of anonsub
1592 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1593 the kind of subroutine:
1595 padtidy_SUB ordinary subroutine
1596 padtidy_SUBCLONE prototype for lexical closure
1597 padtidy_FORMAT format
1602 /* XXX DAPM surely most of this stuff should be done properly
1603 * at the right time beforehand, rather than going around afterwards
1604 * cleaning up our mistakes ???
1608 Perl_pad_tidy(pTHX_ padtidy_type type)
1612 ASSERT_CURPAD_ACTIVE("pad_tidy");
1614 /* If this CV has had any 'eval-capable' ops planted in it
1615 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1616 * anon prototypes in the chain of CVs should be marked as cloneable,
1617 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1618 * the right CvOUTSIDE.
1619 * If running with -d, *any* sub may potentially have an eval
1620 * executed within it.
1623 if (PL_cv_has_eval || PL_perldb) {
1625 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1626 if (cv != PL_compcv && CvCOMPILED(cv))
1627 break; /* no need to mark already-compiled code */
1629 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1630 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1636 /* extend curpad to match namepad */
1637 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1638 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1640 if (type == padtidy_SUBCLONE) {
1641 SV * const * const namep = AvARRAY(PL_comppad_name);
1644 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1647 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1650 * The only things that a clonable function needs in its
1651 * pad are anonymous subs.
1652 * The rest are created anew during cloning.
1654 if (!((namesv = namep[ix]) != NULL &&
1655 namesv != &PL_sv_undef &&
1656 *SvPVX_const(namesv) == '&'))
1658 SvREFCNT_dec(PL_curpad[ix]);
1659 PL_curpad[ix] = NULL;
1663 else if (type == padtidy_SUB) {
1664 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1665 AV * const av = newAV(); /* Will be @_ */
1666 av_store(PL_comppad, 0, MUTABLE_SV(av));
1670 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1671 SV * const * const namep = AvARRAY(PL_comppad_name);
1673 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1674 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1676 if (!SvPADMY(PL_curpad[ix])) {
1677 SvPADTMP_on(PL_curpad[ix]);
1678 } else if (!SvFAKE(namep[ix])) {
1679 /* This is a work around for how the current implementation of
1680 ?{ } blocks in regexps interacts with lexicals.
1682 One of our lexicals.
1683 Can't do this on all lexicals, otherwise sub baz() won't
1692 because completion of compiling &bar calling pad_tidy()
1693 would cause (top level) $foo to be marked as stale, and
1694 "no longer available". */
1695 SvPADSTALE_on(PL_curpad[ix]);
1699 PL_curpad = AvARRAY(PL_comppad);
1703 =for apidoc m|void|pad_free|PADOFFSET po
1705 Free the SV at offset po in the current pad.
1710 /* XXX DAPM integrate with pad_swipe ???? */
1712 Perl_pad_free(pTHX_ PADOFFSET po)
1715 ASSERT_CURPAD_LEGAL("pad_free");
1718 if (AvARRAY(PL_comppad) != PL_curpad)
1719 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1720 AvARRAY(PL_comppad), PL_curpad);
1722 Perl_croak(aTHX_ "panic: pad_free po");
1724 DEBUG_X(PerlIO_printf(Perl_debug_log,
1725 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1726 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1729 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1730 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1732 if ((I32)po < PL_padix)
1737 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1739 Dump the contents of a padlist
1745 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1754 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1759 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1760 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1761 pname = AvARRAY(pad_name);
1762 ppad = AvARRAY(pad);
1763 Perl_dump_indent(aTHX_ level, file,
1764 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1765 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1768 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1769 const SV *namesv = pname[ix];
1770 if (namesv && namesv == &PL_sv_undef) {
1775 Perl_dump_indent(aTHX_ level+1, file,
1776 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1779 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1780 SvPVX_const(namesv),
1781 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1782 (unsigned long)PARENT_PAD_INDEX(namesv)
1786 Perl_dump_indent(aTHX_ level+1, file,
1787 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1790 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1791 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1792 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1797 Perl_dump_indent(aTHX_ level+1, file,
1798 "%2d. 0x%"UVxf"<%lu>\n",
1801 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1810 =for apidoc m|void|cv_dump|CV *cv|const char *title
1812 dump the contents of a CV
1818 S_cv_dump(pTHX_ const CV *cv, const char *title)
1821 const CV * const outside = CvOUTSIDE(cv);
1822 AV* const padlist = CvPADLIST(cv);
1824 PERL_ARGS_ASSERT_CV_DUMP;
1826 PerlIO_printf(Perl_debug_log,
1827 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1830 (CvANON(cv) ? "ANON"
1831 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1832 : (cv == PL_main_cv) ? "MAIN"
1833 : CvUNIQUE(cv) ? "UNIQUE"
1834 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1837 : CvANON(outside) ? "ANON"
1838 : (outside == PL_main_cv) ? "MAIN"
1839 : CvUNIQUE(outside) ? "UNIQUE"
1840 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1842 PerlIO_printf(Perl_debug_log,
1843 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1844 do_dump_pad(1, Perl_debug_log, padlist, 1);
1847 #endif /* DEBUGGING */
1850 =for apidoc Am|CV *|cv_clone|CV *proto
1852 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1853 of the function: its code, pad structure, and other attributes.
1854 The prototype is combined with a capture of outer lexicals to which the
1855 code refers, which are taken from the currently-executing instance of
1856 the immediately surrounding code.
1862 Perl_cv_clone(pTHX_ CV *proto)
1866 AV* const protopadlist = CvPADLIST(proto);
1867 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1868 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1869 SV** const pname = AvARRAY(protopad_name);
1870 SV** const ppad = AvARRAY(protopad);
1871 const I32 fname = AvFILLp(protopad_name);
1872 const I32 fpad = AvFILLp(protopad);
1878 PERL_ARGS_ASSERT_CV_CLONE;
1880 assert(!CvUNIQUE(proto));
1882 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1883 * to a prototype; we instead want the cloned parent who called us.
1884 * Note that in general for formats, CvOUTSIDE != find_runcv */
1886 outside = CvOUTSIDE(proto);
1887 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1888 outside = find_runcv(NULL);
1889 depth = CvDEPTH(outside);
1890 assert(depth || SvTYPE(proto) == SVt_PVFM);
1893 assert(CvPADLIST(outside));
1896 SAVESPTR(PL_compcv);
1898 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1899 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1902 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1904 CvGV_set(cv,CvGV(proto));
1905 CvSTASH_set(cv, CvSTASH(proto));
1907 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1909 CvSTART(cv) = CvSTART(proto);
1910 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1911 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1914 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1916 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1918 av_fill(PL_comppad, fpad);
1919 for (ix = fname; ix > 0; ix--)
1920 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1922 PL_curpad = AvARRAY(PL_comppad);
1924 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1926 for (ix = fpad; ix > 0; ix--) {
1927 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1929 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1930 if (SvFAKE(namesv)) { /* lexical from outside? */
1931 sv = outpad[PARENT_PAD_INDEX(namesv)];
1933 /* formats may have an inactive parent,
1934 while my $x if $false can leave an active var marked as
1935 stale. And state vars are always available */
1936 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1937 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1938 "Variable \"%"SVf"\" is not available", namesv);
1942 SvREFCNT_inc_simple_void_NN(sv);
1945 const char sigil = SvPVX_const(namesv)[0];
1947 sv = SvREFCNT_inc(ppad[ix]);
1948 else if (sigil == '@')
1949 sv = MUTABLE_SV(newAV());
1950 else if (sigil == '%')
1951 sv = MUTABLE_SV(newHV());
1955 /* reset the 'assign only once' flag on each state var */
1956 if (SvPAD_STATE(namesv))
1960 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1961 sv = SvREFCNT_inc_NN(ppad[ix]);
1971 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1972 cv_dump(outside, "Outside");
1973 cv_dump(proto, "Proto");
1980 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1981 * The prototype was marked as a candiate for const-ization,
1982 * so try to grab the current const value, and if successful,
1983 * turn into a const sub:
1985 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1988 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1999 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2001 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2002 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2003 moved to a pre-existing CV struct.
2009 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2013 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2014 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2015 SV ** const namepad = AvARRAY(comppad_name);
2016 SV ** const curpad = AvARRAY(comppad);
2018 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2019 PERL_UNUSED_ARG(old_cv);
2021 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2022 const SV * const namesv = namepad[ix];
2023 if (namesv && namesv != &PL_sv_undef
2024 && *SvPVX_const(namesv) == '&')
2026 CV * const innercv = MUTABLE_CV(curpad[ix]);
2027 assert(CvWEAKOUTSIDE(innercv));
2028 assert(CvOUTSIDE(innercv) == old_cv);
2029 CvOUTSIDE(innercv) = new_cv;
2035 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2037 Push a new pad frame onto the padlist, unless there's already a pad at
2038 this depth, in which case don't bother creating a new one. Then give
2039 the new pad an @_ in slot zero.
2045 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2049 PERL_ARGS_ASSERT_PAD_PUSH;
2051 if (depth > AvFILLp(padlist)) {
2052 SV** const svp = AvARRAY(padlist);
2053 AV* const newpad = newAV();
2054 SV** const oldpad = AvARRAY(svp[depth-1]);
2055 I32 ix = AvFILLp((const AV *)svp[1]);
2056 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2057 SV** const names = AvARRAY(svp[0]);
2060 for ( ;ix > 0; ix--) {
2061 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2062 const char sigil = SvPVX_const(names[ix])[0];
2063 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2064 || (SvFLAGS(names[ix]) & SVpad_STATE)
2067 /* outer lexical or anon code */
2068 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2070 else { /* our own lexical */
2073 sv = MUTABLE_SV(newAV());
2074 else if (sigil == '%')
2075 sv = MUTABLE_SV(newHV());
2078 av_store(newpad, ix, sv);
2082 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2083 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2086 /* save temporaries on recursion? */
2087 SV * const sv = newSV(0);
2088 av_store(newpad, ix, sv);
2093 av_store(newpad, 0, MUTABLE_SV(av));
2096 av_store(padlist, depth, MUTABLE_SV(newpad));
2097 AvFILLp(padlist) = depth;
2102 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2104 Looks up the type of the lexical variable at position I<po> in the
2105 currently-compiling pad. If the variable is typed, the stash of the
2106 class to which it is typed is returned. If not, C<NULL> is returned.
2112 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2115 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2116 if ( SvPAD_TYPED(*av) ) {
2117 return SvSTASH(*av);
2122 #if defined(USE_ITHREADS)
2124 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2127 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2135 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2138 PERL_ARGS_ASSERT_PADLIST_DUP;
2143 if (param->flags & CLONEf_COPY_STACKS
2144 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2145 dstpad = av_dup_inc(srcpad, param);
2146 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2148 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2149 to build anything other than the first level of pads. */
2151 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2153 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2154 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2155 SV **oldpad = AvARRAY(srcpad1);
2159 /* Look for it in the table first, as the padlist may have ended up
2160 as an element of @DB::args (or theoretically even @_), so it may
2161 may have been cloned already. It may also be there because of
2162 how Perl_sv_compile_2op() "works". :-( */
2163 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2166 return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2169 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2170 av_extend(dstpad, 1);
2171 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2172 names = AvARRAY(AvARRAY(dstpad)[0]);
2176 av_extend(pad1, ix);
2177 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2178 pad1a = AvARRAY(pad1);
2179 AvFILLp(dstpad) = 1;
2184 for ( ;ix > 0; ix--) {
2187 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2188 const char sigil = SvPVX_const(names[ix])[0];
2189 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2190 || (SvFLAGS(names[ix]) & SVpad_STATE)
2193 /* outer lexical or anon code */
2194 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2196 else { /* our own lexical */
2197 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2198 /* This is a work around for how the current
2199 implementation of ?{ } blocks in regexps
2200 interacts with lexicals. */
2201 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2206 sv = MUTABLE_SV(newAV());
2207 else if (sigil == '%')
2208 sv = MUTABLE_SV(newHV());
2216 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2217 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2220 /* save temporaries on recursion? */
2221 SV * const sv = newSV(0);
2224 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2225 FIXTHAT before merging this branch.
2226 (And I know how to) */
2227 if (SvPADMY(oldpad[ix]))
2235 args = newAV(); /* Will be @_ */
2237 pad1a[0] = (SV *)args;
2245 #endif /* USE_ITHREADS */
2249 * c-indentation-style: bsd
2251 * indent-tabs-mode: t
2254 * ex: set ts=8 sts=4 sw=4 noet: