This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert ‘Used pad name lists for pad ids’
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
1129b882
NC
3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
dd2155a4
DM
5 *
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.
4ac71550
TC
8 */
9
10/*
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
dd2155a4 17 *
4ac71550 18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
dd2155a4
DM
19 */
20
21/* XXX DAPM
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.
25 */
26
27/*
28=head1 Pad Data Structures
29
cc76b5cc 30=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
166f8a29 31
58a9b2fe 32CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
cc76b5cc
Z
33scratchpad, which stores lexical variables and opcode temporary and
34per-thread values.
dd2155a4 35
58a9b2fe 36For these purposes "formats" are a kind-of CV; eval""s are too (except they're
dd2155a4 37not callable at will and are always thrown away after the eval"" is done
58a9b2fe 38executing). Require'd files are simply evals without any outer lexical
b5c19bd7 39scope.
dd2155a4 40
eacbb379 41XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
dd2155a4 42but that is really the callers pad (a slot of which is allocated by
eacbb379
DD
43every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
44determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
45internal purpose in XSUBs.
dd2155a4 46
58a9b2fe 47The PADLIST has a C array where pads are stored.
dd2155a4 48
9b7476d7
FC
49The 0th entry of the PADLIST is a PADNAMELIST
50which represents the "names" or rather
58a9b2fe 51the "static type information" for lexicals. The individual elements of a
9b7476d7 52PADNAMELIST are PADNAMEs. Future
7a5eb04d 53refactorings might stop the PADNAMELIST from being stored in the PADLIST's
86d2498c 54array, so don't rely on it. See L</PadlistNAMES>.
dd2155a4 55
58a9b2fe
FC
56The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
57at that depth of recursion into the CV. The 0th slot of a frame AV is an
58AV which is @_. Other entries are storage for variables and op targets.
dd2155a4 59
58a9b2fe 60Iterating over the PADNAMELIST iterates over all possible pad
272ce8bb 61items. Pad slots for targets (SVs_PADTMP)
307a54be
FC
62and GVs end up having &PL_padname_undef "names", while slots for constants
63have &PL_padname_const "names" (see pad_alloc()). That &PL_padname_undef
64and &PL_padname_const are used is an implementation detail subject to
65change. To test for them, use C<!PadnamePV(name)> and C<PadnamePV(name)
66&& !PadnameLEN(name)>, respectively.
dd2155a4 67
307a54be 68Only my/our variable slots get valid names.
dd2155a4
DM
69The rest are op targets/GVs/constants which are statically allocated
70or resolved at compile time. These don't have names by which they
58a9b2fe 71can be looked up from Perl code at run time through eval"" the way
dd2155a4
DM
72my/our variables can be. Since they can't be looked up by "name"
73but only by their index allocated at compile time (which is usually
74in PL_op->op_targ), wasting a name SV for them doesn't make sense.
75
307a54be
FC
76The pad names in the PADNAMELIST have their PV holding the name of
77the variable. The COP_SEQ_RANGE_LOW and _HIGH fields form a range
78(low+1..high inclusive) of cop_seq numbers for which the name is
79valid. During compilation, these fields may hold the special value
61f4bfbf 80PERL_PADSEQ_INTRO to indicate various stages:
0d311cdb
DM
81
82 COP_SEQ_RANGE_LOW _HIGH
83 ----------------- -----
84 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
85 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
86 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
87
307a54be
FC
88For typed lexicals PadnameTYPE points at the type stash. For C<our>
89lexicals, PadnameOURSTASH points at the stash of the associated global (so
90that duplicate C<our> declarations in the same package can be detected).
91PadnameGEN is sometimes used to store the generation number during
92compilation.
93
94If PadnameOUTER is set on the pad name, then that slot in the frame AV
95is a REFCNT'ed reference to a lexical from "outside". Such entries
96are sometimes referred to as 'fake'. In this case, the name does not
97use 'low' and 'high' to store a cop_seq range, since it is in scope
98throughout. Instead 'high' stores some flags containing info about
b5c19bd7 99the real lexical (is it declared in an anon, and is it capable of being
307a54be 100instantiated multiple times?), and for fake ANONs, 'low' contains the index
b5c19bd7
DM
101within the parent's pad where the lexical's value is stored, to make
102cloning quicker.
dd2155a4 103
58a9b2fe 104If the 'name' is '&' the corresponding entry in the PAD
dd2155a4 105is a CV representing a possible closure.
dd2155a4 106
71f882da
DM
107Note that formats are treated as anon subs, and are cloned each time
108write is called (if necessary).
109
ab8e66c1 110The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
58a9b2fe
FC
111and set on scope exit. This allows the
112'Variable $x is not available' warning
e6e7068b
DM
113to be generated in evals, such as
114
115 { my $x = 1; sub f { eval '$x'} } f();
116
c9956dca
FC
117For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised',
118but this internal state is stored in a separate pad entry.
d1186544 119
36c300bb 120=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
cc76b5cc
Z
121
122During compilation, this points to the array containing the names part
123of the pad for the currently-compiling code.
124
36c300bb 125=for apidoc AmxU|PAD *|PL_comppad
cc76b5cc
Z
126
127During compilation, this points to the array containing the values
128part of the pad for the currently-compiling code. (At runtime a CV may
129have many such value arrays; at compile time just one is constructed.)
130At runtime, this points to the array containing the currently-relevant
131values for the pad for the currently-executing code.
132
133=for apidoc AmxU|SV **|PL_curpad
134
135Points directly to the body of the L</PL_comppad> array.
c14a2249 136(I.e., this is C<PAD_ARRAY(PL_comppad)>.)
cc76b5cc 137
dd2155a4
DM
138=cut
139*/
140
141
142#include "EXTERN.h"
143#define PERL_IN_PAD_C
144#include "perl.h"
952306ac 145#include "keywords.h"
dd2155a4 146
3441fb63 147#define COP_SEQ_RANGE_LOW_set(sv,val) \
0f94cb1f 148 STMT_START { (sv)->xpadn_low = (val); } STMT_END
3441fb63 149#define COP_SEQ_RANGE_HIGH_set(sv,val) \
0f94cb1f 150 STMT_START { (sv)->xpadn_high = (val); } STMT_END
809abb02 151
0f94cb1f
FC
152#define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
153#define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
dd2155a4 154
eacbb379
DD
155#ifdef DEBUGGING
156void
e69651e7 157Perl_set_padlist(CV * cv, PADLIST *padlist){
eacbb379
DD
158 PERL_ARGS_ASSERT_SET_PADLIST;
159# if PTRSIZE == 8
e5964223 160 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
eacbb379 161# elif PTRSIZE == 4
e5964223 162 assert((Size_t)padlist != UINT64_C(0xEFEFEFEF));
eacbb379
DD
163# else
164# error unknown pointer size
165# endif
e5964223 166 assert(!CvISXSUB(cv));
eacbb379
DD
167 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
168}
169#endif
5b16296c
BF
170
171/*
cc76b5cc 172=for apidoc Am|PADLIST *|pad_new|int flags
dd2155a4 173
cc76b5cc
Z
174Create a new padlist, updating the global variables for the
175currently-compiling padlist to point to the new padlist. The following
176flags can be OR'ed together:
dd2155a4
DM
177
178 padnew_CLONE this pad is for a cloned CV
cc76b5cc 179 padnew_SAVE save old globals on the save stack
dd2155a4
DM
180 padnew_SAVESUB also save extra stuff for start of sub
181
182=cut
183*/
184
185PADLIST *
c7c737cb 186Perl_pad_new(pTHX_ int flags)
dd2155a4 187{
7261499d 188 PADLIST *padlist;
9b7476d7
FC
189 PADNAMELIST *padname;
190 PAD *pad;
7261499d 191 PAD **ary;
dd2155a4 192
f3548bdc
DM
193 ASSERT_CURPAD_LEGAL("pad_new");
194
dd2155a4
DM
195 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
196 * vars (based on flags) rather than storing vals + addresses for
197 * each individually. Also see pad_block_start.
198 * XXX DAPM Try to see whether all these conditionals are required
199 */
200
201 /* save existing state, ... */
202
203 if (flags & padnew_SAVE) {
3979c56f 204 SAVECOMPPAD();
dd2155a4 205 if (! (flags & padnew_CLONE)) {
cbacc9aa 206 SAVESPTR(PL_comppad_name);
dd2155a4 207 SAVEI32(PL_padix);
b54c5e14 208 SAVEI32(PL_constpadix);
dd2155a4
DM
209 SAVEI32(PL_comppad_name_fill);
210 SAVEI32(PL_min_intro_pending);
211 SAVEI32(PL_max_intro_pending);
8bbe96d7 212 SAVEBOOL(PL_cv_has_eval);
dd2155a4 213 if (flags & padnew_SAVESUB) {
f0cb02e3 214 SAVEBOOL(PL_pad_reset_pending);
dd2155a4
DM
215 }
216 }
217 }
218 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
219 * saved - check at some pt that this is okay */
220
221 /* ... create new pad ... */
222
7261499d 223 Newxz(padlist, 1, PADLIST);
dd2155a4
DM
224 pad = newAV();
225
226 if (flags & padnew_CLONE) {
227 /* XXX DAPM I dont know why cv_clone needs it
228 * doing differently yet - perhaps this separate branch can be
229 * dispensed with eventually ???
230 */
231
e1ec3a88 232 AV * const a0 = newAV(); /* will be @_ */
ad64d0ec 233 av_store(pad, 0, MUTABLE_SV(a0));
11ca45c0 234 AvREIFY_only(a0);
9ef8d569 235
9b7476d7 236 PadnamelistREFCNT(padname = PL_comppad_name)++;
dd2155a4
DM
237 }
238 else {
b4db5868 239 padlist->xpadl_id = PL_padlist_generation++;
a0714e2c 240 av_store(pad, 0, NULL);
9b7476d7 241 padname = newPADNAMELIST(0);
0f94cb1f 242 padnamelist_store(padname, 0, &PL_padname_undef);
dd2155a4
DM
243 }
244
7a6072a8
NC
245 /* Most subroutines never recurse, hence only need 2 entries in the padlist
246 array - names, and depth=1. The default for av_store() is to allocate
247 0..3, and even an explicit call to av_extend() with <3 will be rounded
248 up, so we inline the allocation of the array here. */
7261499d 249 Newx(ary, 2, PAD *);
86d2498c
FC
250 PadlistMAX(padlist) = 1;
251 PadlistARRAY(padlist) = ary;
9b7476d7 252 ary[0] = (PAD *)padname;
7261499d 253 ary[1] = pad;
dd2155a4
DM
254
255 /* ... then update state variables */
256
403799bf
NC
257 PL_comppad = pad;
258 PL_curpad = AvARRAY(pad);
dd2155a4
DM
259
260 if (! (flags & padnew_CLONE)) {
9ef8d569 261 PL_comppad_name = padname;
dd2155a4
DM
262 PL_comppad_name_fill = 0;
263 PL_min_intro_pending = 0;
264 PL_padix = 0;
b54c5e14 265 PL_constpadix = 0;
b5c19bd7 266 PL_cv_has_eval = 0;
dd2155a4
DM
267 }
268
269 DEBUG_X(PerlIO_printf(Perl_debug_log,
b5c19bd7 270 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
dd2155a4 271 " name=0x%"UVxf" flags=0x%"UVxf"\n",
b5c19bd7 272 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
dd2155a4
DM
273 PTR2UV(padname), (UV)flags
274 )
275 );
276
277 return (PADLIST*)padlist;
278}
279
dd2155a4 280
c4528262
NC
281/*
282=head1 Embedding Functions
283
284=for apidoc cv_undef
285
72d33970 286Clear out all the active components of a CV. This can happen either
c4528262
NC
287by an explicit C<undef &foo>, or by the reference count going to zero.
288In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
289children can still follow the full lexical scope chain.
290
291=cut
292*/
293
294void
295Perl_cv_undef(pTHX_ CV *cv)
296{
b7acb0a3
FC
297 PERL_ARGS_ASSERT_CV_UNDEF;
298 cv_undef_flags(cv, 0);
299}
300
301void
302Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
303{
52ec28d5
DD
304 CV cvbody;/*CV body will never be realloced inside this func,
305 so dont read it more than once, use fake CV so existing macros
306 will work, the indirection and CV head struct optimized away*/
307 SvANY(&cvbody) = SvANY(cv);
c4528262 308
b7acb0a3 309 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
c4528262
NC
310
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
312 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
313 PTR2UV(cv), PTR2UV(PL_comppad))
314 );
315
52ec28d5
DD
316 if (CvFILE(&cvbody)) {
317 char * file = CvFILE(&cvbody);
318 CvFILE(&cvbody) = NULL;
319 if(CvDYNFILE(&cvbody))
320 Safefree(file);
c4528262 321 }
dd2155a4 322
52ec28d5
DD
323 /* CvSLABBED_off(&cvbody); *//* turned off below */
324 /* release the sub's body */
325 if (!CvISXSUB(&cvbody)) {
326 if(CvROOT(&cvbody)) {
327 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
328 if (CvDEPTHunsafe(&cvbody)) {
329 assert(SvTYPE(cv) == SVt_PVCV);
330 Perl_croak_nocontext("Can't undef active subroutine");
331 }
332 ENTER;
333
334 PAD_SAVE_SETNULLPAD();
335
336 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
337 op_free(CvROOT(&cvbody));
338 CvROOT(&cvbody) = NULL;
339 CvSTART(&cvbody) = NULL;
340 LEAVE;
341 }
342 else if (CvSLABBED(&cvbody)) {
343 if( CvSTART(&cvbody)) {
344 ENTER;
345 PAD_SAVE_SETNULLPAD();
346
347 /* discard any leaked ops */
348 if (PL_parser)
349 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
350 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
351 CvSTART(&cvbody) = NULL;
352
353 LEAVE;
354 }
7aef8e5b 355#ifdef DEBUGGING
52ec28d5 356 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
8be227ab 357#endif
52ec28d5
DD
358 }
359 }
360 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
361 CvXSUB(&cvbody) = NULL;
362 }
c4528262 363 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
2f14e398 364 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
b7acb0a3 365 if (!(flags & CV_UNDEF_KEEP_NAME)) {
52ec28d5
DD
366 if (CvNAMED(&cvbody)) {
367 CvNAME_HEK_set(&cvbody, NULL);
368 CvNAMED_off(&cvbody);
b7acb0a3
FC
369 }
370 else CvGV_set(cv, NULL);
371 }
c4528262 372
c2736fce
NC
373 /* This statement and the subsequence if block was pad_undef(). */
374 pad_peg("pad_undef");
375
eacbb379 376 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
c2736fce 377 I32 ix;
52ec28d5 378 const PADLIST *padlist = CvPADLIST(&cvbody);
c2736fce
NC
379
380 /* Free the padlist associated with a CV.
381 If parts of it happen to be current, we null the relevant PL_*pad*
382 global vars so that we don't have any dangling references left.
383 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
384 subs to the outer of this cv. */
385
386 DEBUG_X(PerlIO_printf(Perl_debug_log,
387 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
388 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
389 );
390
391 /* detach any '&' anon children in the pad; if afterwards they
392 * are still live, fix up their CvOUTSIDEs to point to our outside,
393 * bypassing us. */
394 /* XXX DAPM for efficiency, we should only do this if we know we have
395 * children, or integrate this loop with general cleanup */
396
397 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
52ec28d5
DD
398 CV * const outercv = CvOUTSIDE(&cvbody);
399 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
9b7476d7 400 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
cab74fca 401 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
86d2498c 402 PAD * const comppad = PadlistARRAY(padlist)[1];
c2736fce 403 SV ** const curpad = AvARRAY(comppad);
9b7476d7 404 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
cab74fca
FC
405 PADNAME * const name = namepad[ix];
406 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
c2736fce
NC
407 {
408 CV * const innercv = MUTABLE_CV(curpad[ix]);
409 U32 inner_rc = SvREFCNT(innercv);
410 assert(inner_rc);
e09ac076 411 assert(SvTYPE(innercv) != SVt_PVFM);
c2736fce
NC
412
413 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
414 curpad[ix] = NULL;
fc2b2dca 415 SvREFCNT_dec_NN(innercv);
c2736fce
NC
416 inner_rc--;
417 }
418
419 /* in use, not just a prototype */
420 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
421 assert(CvWEAKOUTSIDE(innercv));
422 /* don't relink to grandfather if he's being freed */
423 if (outercv && SvREFCNT(outercv)) {
424 CvWEAKOUTSIDE_off(innercv);
425 CvOUTSIDE(innercv) = outercv;
426 CvOUTSIDE_SEQ(innercv) = seq;
427 SvREFCNT_inc_simple_void_NN(outercv);
428 }
429 else {
430 CvOUTSIDE(innercv) = NULL;
431 }
432 }
433 }
434 }
435 }
436
86d2498c 437 ix = PadlistMAX(padlist);
aa2f79cf 438 while (ix > 0) {
86d2498c 439 PAD * const sv = PadlistARRAY(padlist)[ix--];
c2736fce 440 if (sv) {
7261499d 441 if (sv == PL_comppad) {
c2736fce
NC
442 PL_comppad = NULL;
443 PL_curpad = NULL;
444 }
fc2b2dca 445 SvREFCNT_dec_NN(sv);
c2736fce 446 }
aa2f79cf
NC
447 }
448 {
9b7476d7
FC
449 PADNAMELIST * const names = PadlistNAMES(padlist);
450 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
aa2f79cf 451 PL_comppad_name = NULL;
9b7476d7 452 PadnamelistREFCNT_dec(names);
c2736fce 453 }
86d2498c 454 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
7261499d 455 Safefree(padlist);
eacbb379 456 CvPADLIST_set(&cvbody, NULL);
c2736fce 457 }
db6e00bd
DD
458 else if (CvISXSUB(&cvbody))
459 CvHSCXT(&cvbody) = NULL;
eacbb379 460 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
c2736fce 461
c4528262
NC
462
463 /* remove CvOUTSIDE unless this is an undef rather than a free */
52ec28d5
DD
464 if (!SvREFCNT(cv)) {
465 CV * outside = CvOUTSIDE(&cvbody);
466 if(outside) {
467 CvOUTSIDE(&cvbody) = NULL;
468 if (!CvWEAKOUTSIDE(&cvbody))
469 SvREFCNT_dec_NN(outside);
470 }
c4528262 471 }
52ec28d5
DD
472 if (CvCONST(&cvbody)) {
473 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
474 /* CvCONST_off(cv); *//* turned off below */
c4528262
NC
475 }
476 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
b7acb0a3
FC
477 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
478 * LEXICAL, which are used to determine the sub's name. */
52ec28d5 479 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
b7acb0a3 480 |CVf_NAMED);
c4528262 481}
dd2155a4 482
50dc2bd3
FC
483/*
484=for apidoc cv_forget_slab
485
486When a CV has a reference count on its slab (CvSLABBED), it is responsible
487for making sure it is freed. (Hence, no two CVs should ever have a
488reference count on the same slab.) The CV only needs to reference the slab
489during compilation. Once it is compiled and CvROOT attached, it has
490finished its job, so it can forget the slab.
491
492=cut
493*/
494
8be227ab
FC
495void
496Perl_cv_forget_slab(pTHX_ CV *cv)
497{
498 const bool slabbed = !!CvSLABBED(cv);
3107b51f 499 OPSLAB *slab = NULL;
8be227ab
FC
500
501 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
502
503 if (!slabbed) return;
504
505 CvSLABBED_off(cv);
506
3107b51f
FC
507 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
508 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
7aef8e5b 509#ifdef DEBUGGING
eb212a1c 510 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
7aef8e5b 511#endif
3107b51f 512
3107b51f 513 if (slab) {
f3e29105
NC
514#ifdef PERL_DEBUG_READONLY_OPS
515 const size_t refcnt = slab->opslab_refcnt;
516#endif
3107b51f 517 OpslabREFCNT_dec(slab);
f3e29105 518#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 519 if (refcnt > 1) Slab_to_ro(slab);
8be227ab 520#endif
f3e29105 521 }
7aef8e5b 522}
8be227ab 523
cc76b5cc 524/*
307a54be 525=for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
cc76b5cc 526
1a115e49
FC
527Allocates a place in the currently-compiling
528pad (via L<perlapi/pad_alloc>) and
307a54be
FC
529then stores a name for that entry. I<name> is adopted and
530becomes the name entry; it must already contain the name
531string. I<typestash> and I<ourstash> and the C<padadd_STATE>
532flag get added to I<name>. None of the other
1a115e49 533processing of L<perlapi/pad_add_name_pvn>
cc76b5cc
Z
534is done. Returns the offset of the allocated pad slot.
535
536=cut
537*/
538
3291825f 539static PADOFFSET
e1c02f84
FC
540S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
541 HV *ourstash)
3291825f 542{
3291825f
NC
543 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
544
cc76b5cc 545 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
3291825f 546
cc76b5cc 547 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
3291825f
NC
548
549 if (typestash) {
e1c02f84 550 SvPAD_TYPED_on(name);
0f94cb1f
FC
551 PadnameTYPE(name) =
552 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
3291825f
NC
553 }
554 if (ourstash) {
e1c02f84
FC
555 SvPAD_OUR_on(name);
556 SvOURSTASH_set(name, ourstash);
3291825f
NC
557 SvREFCNT_inc_simple_void_NN(ourstash);
558 }
59cfed7d 559 else if (flags & padadd_STATE) {
e1c02f84 560 SvPAD_STATE_on(name);
3291825f
NC
561 }
562
0f94cb1f 563 padnamelist_store(PL_comppad_name, offset, name);
7db6405c 564 PadnamelistMAXNAMED(PL_comppad_name) = offset;
3291825f
NC
565 return offset;
566}
567
dd2155a4 568/*
cc76b5cc 569=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
dd2155a4 570
cc76b5cc
Z
571Allocates a place in the currently-compiling pad for a named lexical
572variable. Stores the name and other metadata in the name part of the
573pad, and makes preparations to manage the variable's lexical scoping.
574Returns the offset of the allocated pad slot.
dd2155a4 575
cc76b5cc
Z
576I<namepv>/I<namelen> specify the variable's name, including leading sigil.
577If I<typestash> is non-null, the name is for a typed lexical, and this
578identifies the type. If I<ourstash> is non-null, it's a lexical reference
579to a package variable, and this identifies the package. The following
580flags can be OR'ed together:
581
582 padadd_OUR redundantly specifies if it's a package var
583 padadd_STATE variable will retain value persistently
584 padadd_NO_DUP_CHECK skip check for lexical shadowing
dd2155a4
DM
585
586=cut
587*/
588
dd2155a4 589PADOFFSET
cc76b5cc
Z
590Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
591 U32 flags, HV *typestash, HV *ourstash)
dd2155a4 592{
3291825f 593 PADOFFSET offset;
e1c02f84 594 PADNAME *name;
dd2155a4 595
cc76b5cc 596 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
7918f24d 597
2502ffdf 598 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
cc76b5cc 599 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
cca43f78
NC
600 (UV)flags);
601
0f94cb1f 602 name = newPADNAMEpvn(namepv, namelen);
dd2155a4 603
59cfed7d 604 if ((flags & padadd_NO_DUP_CHECK) == 0) {
c2b36a6d 605 ENTER;
0f94cb1f 606 SAVEFREEPADNAME(name); /* in case of fatal warnings */
2d12d04f 607 /* check for duplicate declaration */
e1c02f84 608 pad_check_dup(name, flags & padadd_OUR, ourstash);
0f94cb1f 609 PadnameREFCNT(name)++;
c2b36a6d 610 LEAVE;
2d12d04f
NC
611 }
612
2502ffdf 613 offset = pad_alloc_name(name, flags, typestash, ourstash);
3291825f
NC
614
615 /* not yet introduced */
e1c02f84
FC
616 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
617 COP_SEQ_RANGE_HIGH_set(name, 0);
3291825f
NC
618
619 if (!PL_min_intro_pending)
620 PL_min_intro_pending = offset;
621 PL_max_intro_pending = offset;
622 /* if it's not a simple scalar, replace with an AV or HV */
c1bf42f3
NC
623 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
624 assert(SvREFCNT(PL_curpad[offset]) == 1);
cc76b5cc 625 if (namelen != 0 && *namepv == '@')
c1bf42f3 626 sv_upgrade(PL_curpad[offset], SVt_PVAV);
cc76b5cc 627 else if (namelen != 0 && *namepv == '%')
c1bf42f3 628 sv_upgrade(PL_curpad[offset], SVt_PVHV);
6d5c2147
FC
629 else if (namelen != 0 && *namepv == '&')
630 sv_upgrade(PL_curpad[offset], SVt_PVCV);
c1bf42f3 631 assert(SvPADMY(PL_curpad[offset]));
3291825f
NC
632 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
633 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
e1c02f84 634 (long)offset, PadnamePV(name),
cc76b5cc 635 PTR2UV(PL_curpad[offset])));
dd2155a4
DM
636
637 return offset;
638}
639
cc76b5cc
Z
640/*
641=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 642
cc76b5cc
Z
643Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
644instead of a string/length pair.
dd2155a4 645
cc76b5cc
Z
646=cut
647*/
648
649PADOFFSET
650Perl_pad_add_name_pv(pTHX_ const char *name,
0e1b3a4b 651 const U32 flags, HV *typestash, HV *ourstash)
cc76b5cc
Z
652{
653 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
654 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
655}
dd2155a4
DM
656
657/*
cc76b5cc 658=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 659
cc76b5cc
Z
660Exactly like L</pad_add_name_pvn>, but takes the name string in the form
661of an SV instead of a string/length pair.
662
663=cut
664*/
665
666PADOFFSET
667Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
668{
669 char *namepv;
670 STRLEN namelen;
671 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
2502ffdf 672 namepv = SvPVutf8(name, namelen);
cc76b5cc
Z
673 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
674}
675
676/*
677=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
678
679Allocates a place in the currently-compiling pad,
680returning the offset of the allocated pad slot.
681No name is initially attached to the pad slot.
682I<tmptype> is a set of flags indicating the kind of pad entry required,
683which will be set in the value SV for the allocated pad entry:
684
685 SVs_PADMY named lexical variable ("my", "our", "state")
686 SVs_PADTMP unnamed temporary store
325e1816
FC
687 SVf_READONLY constant shared between recursion levels
688
689C<SVf_READONLY> has been supported here only since perl 5.20. To work with
c370bd2e
FC
690earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
691does not cause the SV in the pad slot to be marked read-only, but simply
692tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
693least should be treated as such.
cc76b5cc
Z
694
695I<optype> should be an opcode indicating the type of operation that the
696pad entry is to support. This doesn't affect operational semantics,
697but is used for debugging.
dd2155a4
DM
698
699=cut
700*/
701
702/* XXX DAPM integrate alloc(), add_name() and add_anon(),
703 * or at least rationalise ??? */
dd2155a4
DM
704
705PADOFFSET
706Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
707{
708 SV *sv;
709 I32 retval;
710
6136c704 711 PERL_UNUSED_ARG(optype);
f3548bdc
DM
712 ASSERT_CURPAD_ACTIVE("pad_alloc");
713
dd2155a4 714 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
715 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
716 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
717 if (PL_pad_reset_pending)
718 pad_reset();
c0683843 719 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
cc76b5cc 720 /* For a my, simply push a null SV onto the end of PL_comppad. */
235cc2e3 721 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
dd2155a4
DM
722 retval = AvFILLp(PL_comppad);
723 }
724 else {
cc76b5cc
Z
725 /* For a tmp, scan the pad from PL_padix upwards
726 * for a slot which has no name and no active value.
b54c5e14 727 * For a constant, likewise, but use PL_constpadix.
cc76b5cc 728 */
9b7476d7
FC
729 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
730 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
b54c5e14
FC
731 const bool konst = cBOOL(tmptype & SVf_READONLY);
732 retval = konst ? PL_constpadix : PL_padix;
dd2155a4
DM
733 for (;;) {
734 /*
833bf1cd
FC
735 * Entries that close over unavailable variables
736 * in outer subs contain values not marked PADMY.
737 * Thus we must skip, not just pad values that are
dd2155a4 738 * marked as current pad values, but also those with names.
1780e744
FC
739 * If pad_reset is enabled, ‘current’ means different
740 * things depending on whether we are allocating a con-
741 * stant or a target. For a target, things marked PADTMP
742 * can be reused; not so for constants.
dd2155a4 743 */
5e6246a7 744 PADNAME *pn;
b54c5e14 745 if (++retval <= names_fill &&
5e6246a7 746 (pn = names[retval]) && PadnamePV(pn))
dd2155a4 747 continue;
b54c5e14 748 sv = *av_fetch(PL_comppad, retval, TRUE);
a90643eb 749 if (!(SvFLAGS(sv) &
53de1311 750#ifdef USE_PAD_RESET
145bf8ee 751 (konst ? SVs_PADTMP : 0))
a90643eb 752#else
145bf8ee 753 SVs_PADTMP
a90643eb 754#endif
13381c39 755 ))
dd2155a4
DM
756 break;
757 }
b54c5e14 758 if (konst) {
0f94cb1f 759 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
325e1816
FC
760 tmptype &= ~SVf_READONLY;
761 tmptype |= SVs_PADTMP;
762 }
b54c5e14 763 *(konst ? &PL_constpadix : &PL_padix) = retval;
dd2155a4
DM
764 }
765 SvFLAGS(sv) |= tmptype;
766 PL_curpad = AvARRAY(PL_comppad);
767
768 DEBUG_X(PerlIO_printf(Perl_debug_log,
769 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
770 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
771 PL_op_name[optype]));
fd0854ff
DM
772#ifdef DEBUG_LEAKING_SCALARS
773 sv->sv_debug_optype = optype;
774 sv->sv_debug_inpad = 1;
fd0854ff 775#endif
a212c8b5 776 return (PADOFFSET)retval;
dd2155a4
DM
777}
778
779/*
cc76b5cc 780=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
dd2155a4 781
cc76b5cc
Z
782Allocates a place in the currently-compiling pad (via L</pad_alloc>)
783for an anonymous function that is lexically scoped inside the
784currently-compiling function.
785The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
786to the outer scope is weakened to avoid a reference loop.
787
84eea980
FC
788One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
789
cc76b5cc
Z
790I<optype> should be an opcode indicating the type of operation that the
791pad entry is to support. This doesn't affect operational semantics,
792but is used for debugging.
dd2155a4
DM
793
794=cut
795*/
796
797PADOFFSET
cc76b5cc 798Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
dd2155a4
DM
799{
800 PADOFFSET ix;
0f94cb1f 801 PADNAME * const name = newPADNAMEpvn("&", 1);
7918f24d
NC
802
803 PERL_ARGS_ASSERT_PAD_ADD_ANON;
804
1dba731d 805 pad_peg("add_anon");
0d311cdb 806 /* These two aren't used; just make sure they're not equal to
0f94cb1f
FC
807 * PERL_PADSEQ_INTRO. They should be 0 by default. */
808 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
809 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
cc76b5cc 810 ix = pad_alloc(optype, SVs_PADMY);
9b7476d7 811 padnamelist_store(PL_comppad_name, ix, name);
f3548bdc 812 /* XXX DAPM use PL_curpad[] ? */
e09ac076
FC
813 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
814 av_store(PL_comppad, ix, (SV*)func);
815 else {
7c93c29b 816 SV *rv = newRV_noinc((SV *)func);
e09ac076
FC
817 sv_rvweaken(rv);
818 assert (SvTYPE(func) == SVt_PVFM);
819 av_store(PL_comppad, ix, rv);
820 }
7dafbf52
DM
821
822 /* to avoid ref loops, we never have parent + child referencing each
823 * other simultaneously */
e09ac076 824 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
cc76b5cc
Z
825 assert(!CvWEAKOUTSIDE(func));
826 CvWEAKOUTSIDE_on(func);
fc2b2dca 827 SvREFCNT_dec_NN(CvOUTSIDE(func));
7dafbf52 828 }
dd2155a4
DM
829 return ix;
830}
831
dd2155a4 832/*
13087dd8 833=for apidoc pad_check_dup
dd2155a4
DM
834
835Check for duplicate declarations: report any of:
13087dd8 836
dd2155a4 837 * a my in the current scope with the same name;
13087dd8
FC
838 * an our (anywhere in the pad) with the same name and the
839 same stash as C<ourstash>
840
841C<is_our> indicates that the name to check is an 'our' declaration.
dd2155a4
DM
842
843=cut
844*/
845
20381b50 846STATIC void
e1c02f84 847S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
dd2155a4 848{
0aaff5a1 849 PADNAME **svp;
dd2155a4 850 PADOFFSET top, off;
59cfed7d 851 const U32 is_our = flags & padadd_OUR;
dd2155a4 852
7918f24d
NC
853 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
854
f3548bdc 855 ASSERT_CURPAD_ACTIVE("pad_check_dup");
35f82371 856
59cfed7d 857 assert((flags & ~padadd_OUR) == 0);
35f82371 858
9b7476d7 859 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
dd2155a4
DM
860 return; /* nothing to check */
861
9b7476d7
FC
862 svp = PadnamelistARRAY(PL_comppad_name);
863 top = PadnamelistMAX(PL_comppad_name);
dd2155a4
DM
864 /* check the current scope */
865 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
866 * type ? */
867 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
0aaff5a1 868 PADNAME * const sv = svp[off];
53c1dcc0 869 if (sv
0aaff5a1
FC
870 && PadnameLEN(sv) == PadnameLEN(name)
871 && !PadnameOUTER(sv)
0d311cdb
DM
872 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
873 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
0aaff5a1 874 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
dd2155a4 875 {
00b1698f 876 if (is_our && (SvPAD_OUR(sv)))
7f73a9f1 877 break; /* "our" masking "our" */
4eb94d7c 878 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
dd2155a4 879 Perl_warner(aTHX_ packWARN(WARN_MISC),
0aaff5a1 880 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
12bd6ede 881 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
0aaff5a1
FC
882 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
883 PNfARG(sv),
2df5bdd7
DM
884 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
885 ? "scope" : "statement"));
dd2155a4
DM
886 --off;
887 break;
888 }
889 }
890 /* check the rest of the pad */
891 if (is_our) {
61c5492a 892 while (off > 0) {
0aaff5a1 893 PADNAME * const sv = svp[off];
53c1dcc0 894 if (sv
0aaff5a1
FC
895 && PadnameLEN(sv) == PadnameLEN(name)
896 && !PadnameOUTER(sv)
0d311cdb
DM
897 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
898 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
73d95100 899 && SvOURSTASH(sv) == ourstash
0aaff5a1 900 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
dd2155a4
DM
901 {
902 Perl_warner(aTHX_ packWARN(WARN_MISC),
0aaff5a1 903 "\"our\" variable %"PNf" redeclared", PNfARG(sv));
624f69f5 904 if ((I32)off <= PL_comppad_name_floor)
7f73a9f1
RGS
905 Perl_warner(aTHX_ packWARN(WARN_MISC),
906 "\t(Did you mean \"local\" instead of \"our\"?)\n");
dd2155a4
DM
907 break;
908 }
61c5492a
NC
909 --off;
910 }
dd2155a4
DM
911 }
912}
913
914
dd2155a4 915/*
cc76b5cc 916=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
dd2155a4 917
cc76b5cc
Z
918Given the name of a lexical variable, find its position in the
919currently-compiling pad.
920I<namepv>/I<namelen> specify the variable's name, including leading sigil.
921I<flags> is reserved and must be zero.
922If it is not in the current pad but appears in the pad of any lexically
923enclosing scope, then a pseudo-entry for it is added in the current pad.
924Returns the offset in the current pad,
925or C<NOT_IN_PAD> if no such lexical is in scope.
dd2155a4
DM
926
927=cut
928*/
929
930PADOFFSET
cc76b5cc 931Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
dd2155a4 932{
e1c02f84 933 PADNAME *out_pn;
b5c19bd7 934 int out_flags;
929a0744 935 I32 offset;
9b7476d7 936 const PADNAMELIST *namelist;
e1c02f84 937 PADNAME **name_p;
dd2155a4 938
cc76b5cc 939 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
7918f24d 940
cc76b5cc 941 pad_peg("pad_findmy_pvn");
f8f98e0a 942
2502ffdf 943 if (flags)
cc76b5cc 944 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
f8f98e0a
NC
945 (UV)flags);
946
fbb889c8 947 offset = pad_findlex(namepv, namelen, flags,
e1c02f84 948 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
9f7d9405 949 if ((PADOFFSET)offset != NOT_IN_PAD)
929a0744
DM
950 return offset;
951
f0727190
FC
952 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
953 */
954 if (*namepv == '&') return NOT_IN_PAD;
955
929a0744
DM
956 /* look for an our that's being introduced; this allows
957 * our $foo = 0 unless defined $foo;
958 * to not give a warning. (Yes, this is a hack) */
959
9b7476d7
FC
960 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
961 name_p = PadnamelistARRAY(namelist);
962 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
e1c02f84
FC
963 const PADNAME * const name = name_p[offset];
964 if (name && PadnameLEN(name) == namelen
965 && !PadnameOUTER(name)
966 && (PadnameIsOUR(name))
2502ffdf
FC
967 && ( PadnamePV(name) == namepv
968 || memEQ(PadnamePV(name), namepv, namelen) )
e1c02f84 969 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
929a0744
DM
970 )
971 return offset;
972 }
973 return NOT_IN_PAD;
dd2155a4
DM
974}
975
e1f795dc 976/*
cc76b5cc
Z
977=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
978
979Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
980instead of a string/length pair.
981
982=cut
983*/
984
985PADOFFSET
986Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
987{
988 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
989 return pad_findmy_pvn(name, strlen(name), flags);
990}
991
992/*
993=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
994
995Exactly like L</pad_findmy_pvn>, but takes the name string in the form
996of an SV instead of a string/length pair.
997
998=cut
999*/
1000
1001PADOFFSET
1002Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1003{
1004 char *namepv;
1005 STRLEN namelen;
1006 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
2502ffdf 1007 namepv = SvPVutf8(name, namelen);
cc76b5cc
Z
1008 return pad_findmy_pvn(namepv, namelen, flags);
1009}
1010
1011/*
1012=for apidoc Amp|PADOFFSET|find_rundefsvoffset
1013
1014Find the position of the lexical C<$_> in the pad of the
1015currently-executing function. Returns the offset in the current pad,
1016or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1017the global one should be used instead).
1018L</find_rundefsv> is likely to be more convenient.
1019
1020=cut
1021*/
e1f795dc
RGS
1022
1023PADOFFSET
29289021 1024Perl_find_rundefsvoffset(pTHX)
e1f795dc 1025{
e1c02f84 1026 PADNAME *out_pn;
e1f795dc 1027 int out_flags;
fbb889c8 1028 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
e1c02f84 1029 NULL, &out_pn, &out_flags);
e1f795dc 1030}
dd2155a4 1031
dd2155a4 1032/*
cc76b5cc
Z
1033=for apidoc Am|SV *|find_rundefsv
1034
1035Find and return the variable that is named C<$_> in the lexical scope
1036of the currently-executing function. This may be a lexical C<$_>,
1037or will otherwise be the global one.
1038
1039=cut
1040*/
789bd863
VP
1041
1042SV *
1043Perl_find_rundefsv(pTHX)
1044{
e1c02f84 1045 PADNAME *name;
789bd863
VP
1046 int flags;
1047 PADOFFSET po;
1048
fbb889c8 1049 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
e1c02f84 1050 NULL, &name, &flags);
789bd863 1051
e1c02f84 1052 if (po == NOT_IN_PAD || PadnameIsOUR(name))
789bd863
VP
1053 return DEFSV;
1054
1055 return PAD_SVl(po);
1056}
1057
c086f97a
FC
1058SV *
1059Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1060{
e1c02f84 1061 PADNAME *name;
c086f97a
FC
1062 int flags;
1063 PADOFFSET po;
1064
1065 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1066
1067 po = pad_findlex("$_", 2, 0, cv, seq, 1,
e1c02f84 1068 NULL, &name, &flags);
c086f97a 1069
e1c02f84 1070 if (po == NOT_IN_PAD || PadnameIsOUR(name))
c086f97a
FC
1071 return DEFSV;
1072
86d2498c 1073 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
c086f97a
FC
1074}
1075
789bd863 1076/*
e1c02f84 1077=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
dd2155a4 1078
72d33970 1079Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
1080in the inner pads if it's found in an outer one.
1081
1082Returns the offset in the bottom pad of the lex or the fake lex.
1083cv is the CV in which to start the search, and seq is the current cop_seq
72d33970 1084to match against. If warn is true, print appropriate warnings. The out_*
b5c19bd7 1085vars return values, and so are pointers to where the returned values
72d33970 1086should be stored. out_capture, if non-null, requests that the innermost
e1c02f84 1087instance of the lexical is captured; out_name is set to the innermost
307a54be
FC
1088matched pad name or fake pad name; out_flags returns the flags normally
1089associated with the PARENT_FAKELEX_FLAGS field of a fake pad name.
b5c19bd7
DM
1090
1091Note that pad_findlex() is recursive; it recurses up the chain of CVs,
72d33970
FC
1092then comes back down, adding fake entries
1093as it goes. It has to be this way
307a54be 1094because fake names in anon protoypes have to store in xlow the index into
b5c19bd7 1095the parent pad.
dd2155a4
DM
1096
1097=cut
1098*/
1099
b5c19bd7
DM
1100/* the CV has finished being compiled. This is not a sufficient test for
1101 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1102#define CvCOMPILED(cv) CvROOT(cv)
1103
71f882da 1104/* the CV does late binding of its lexicals */
e07561e6 1105#define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
71f882da 1106
445f13ff 1107static void
e6df7a56 1108S_unavailable(pTHX_ PADNAME *name)
445f13ff
FC
1109{
1110 /* diag_listed_as: Variable "%s" is not available */
1111 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
e6df7a56
FC
1112 "%se \"%"PNf"\" is not available",
1113 *PadnamePV(name) == '&'
445f13ff
FC
1114 ? "Subroutin"
1115 : "Variabl",
e6df7a56 1116 PNfARG(name));
445f13ff 1117}
b5c19bd7 1118
dd2155a4 1119STATIC PADOFFSET
fbb889c8 1120S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
e1c02f84 1121 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
dd2155a4 1122{
b5c19bd7
DM
1123 I32 offset, new_offset;
1124 SV *new_capture;
1125 SV **new_capturep;
b70d5558 1126 const PADLIST * const padlist = CvPADLIST(cv);
7ef30830 1127 const bool staleok = !!(flags & padadd_STALEOK);
dd2155a4 1128
7918f24d
NC
1129 PERL_ARGS_ASSERT_PAD_FINDLEX;
1130
2502ffdf
FC
1131 flags &= ~ padadd_STALEOK; /* one-shot flag */
1132 if (flags)
2435e5d3
BF
1133 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1134 (UV)flags);
1135
b5c19bd7 1136 *out_flags = 0;
a3985cdc 1137
b5c19bd7 1138 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
cc76b5cc 1139 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
4c760560 1140 PTR2UV(cv), (int)namelen, namepv, (int)seq,
cc76b5cc 1141 out_capture ? " capturing" : "" ));
dd2155a4 1142
b5c19bd7 1143 /* first, search this pad */
dd2155a4 1144
b5c19bd7
DM
1145 if (padlist) { /* not an undef CV */
1146 I32 fake_offset = 0;
9b7476d7
FC
1147 const PADNAMELIST * const names = PadlistNAMES(padlist);
1148 PADNAME * const * const name_p = PadnamelistARRAY(names);
ee6cee0c 1149
9b7476d7 1150 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
e1c02f84
FC
1151 const PADNAME * const name = name_p[offset];
1152 if (name && PadnameLEN(name) == namelen
2502ffdf
FC
1153 && ( PadnamePV(name) == namepv
1154 || memEQ(PadnamePV(name), namepv, namelen) ))
b5c19bd7 1155 {
e1c02f84 1156 if (PadnameOUTER(name)) {
b5c19bd7 1157 fake_offset = offset; /* in case we don't find a real one */
6012dc80
DM
1158 continue;
1159 }
e1c02f84 1160 if (PadnameIN_SCOPE(name, seq))
03414f05 1161 break;
ee6cee0c
DM
1162 }
1163 }
1164
b5c19bd7
DM
1165 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1166 if (offset > 0) { /* not fake */
1167 fake_offset = 0;
e1c02f84 1168 *out_name = name_p[offset]; /* return the name */
b5c19bd7
DM
1169
1170 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1171 * instances. For now, we just test !CvUNIQUE(cv), but
1172 * ideally, we should detect my's declared within loops
1173 * etc - this would allow a wider range of 'not stayed
486ec47a 1174 * shared' warnings. We also treated already-compiled
b5c19bd7
DM
1175 * lexes as not multi as viewed from evals. */
1176
1177 *out_flags = CvANON(cv) ?
1178 PAD_FAKELEX_ANON :
1179 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1180 ? PAD_FAKELEX_MULTI : 0;
1181
1182 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02
NC
1183 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1184 PTR2UV(cv), (long)offset,
e1c02f84
FC
1185 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1186 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
b5c19bd7
DM
1187 }
1188 else { /* fake match */
1189 offset = fake_offset;
e1c02f84
FC
1190 *out_name = name_p[offset]; /* return the name */
1191 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
b5c19bd7 1192 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
19a5c512 1193 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7 1194 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
e1c02f84 1195 (unsigned long) PARENT_PAD_INDEX(*out_name)
b5c19bd7
DM
1196 ));
1197 }
dd2155a4 1198
b5c19bd7 1199 /* return the lex? */
dd2155a4 1200
b5c19bd7 1201 if (out_capture) {
dd2155a4 1202
b5c19bd7 1203 /* our ? */
e1c02f84 1204 if (PadnameIsOUR(*out_name)) {
a0714e2c 1205 *out_capture = NULL;
b5c19bd7
DM
1206 return offset;
1207 }
ee6cee0c 1208
b5c19bd7
DM
1209 /* trying to capture from an anon prototype? */
1210 if (CvCOMPILED(cv)
1211 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1212 : *out_flags & PAD_FAKELEX_ANON)
1213 {
a2a5de95 1214 if (warn)
445f13ff 1215 S_unavailable(aTHX_
f5658c36 1216 *out_name);
0727928e 1217
a0714e2c 1218 *out_capture = NULL;
b5c19bd7 1219 }
ee6cee0c 1220
b5c19bd7
DM
1221 /* real value */
1222 else {
1223 int newwarn = warn;
1224 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
e1c02f84 1225 && !PadnameIsSTATE(name_p[offset])
b5c19bd7
DM
1226 && warn && ckWARN(WARN_CLOSURE)) {
1227 newwarn = 0;
2a9203e9
FC
1228 /* diag_listed_as: Variable "%s" will not stay
1229 shared */
b5c19bd7 1230 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
2a9203e9
FC
1231 "%se \"%"UTF8f"\" will not stay shared",
1232 *namepv == '&' ? "Subroutin" : "Variabl",
8d98b5bc 1233 UTF8fARG(1, namelen, namepv));
b5c19bd7 1234 }
dd2155a4 1235
b5c19bd7
DM
1236 if (fake_offset && CvANON(cv)
1237 && CvCLONE(cv) &&!CvCLONED(cv))
1238 {
e1c02f84 1239 PADNAME *n;
b5c19bd7
DM
1240 /* not yet caught - look further up */
1241 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1242 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1243 PTR2UV(cv)));
e1c02f84 1244 n = *out_name;
fbb889c8 1245 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
282e1742 1246 CvOUTSIDE_SEQ(cv),
e1c02f84
FC
1247 newwarn, out_capture, out_name, out_flags);
1248 *out_name = n;
b5c19bd7 1249 return offset;
dd2155a4 1250 }
b5c19bd7 1251
86d2498c 1252 *out_capture = AvARRAY(PadlistARRAY(padlist)[
7261499d 1253 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
b5c19bd7
DM
1254 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1255 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 1256 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7 1257
d1186544 1258 if (SvPADSTALE(*out_capture)
7ef30830 1259 && (!CvDEPTH(cv) || !staleok)
e1c02f84 1260 && !PadnameIsSTATE(name_p[offset]))
d1186544 1261 {
445f13ff 1262 S_unavailable(aTHX_
f5658c36 1263 name_p[offset]);
a0714e2c 1264 *out_capture = NULL;
dd2155a4
DM
1265 }
1266 }
b5c19bd7 1267 if (!*out_capture) {
cc76b5cc 1268 if (namelen != 0 && *namepv == '@')
ad64d0ec 1269 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
cc76b5cc 1270 else if (namelen != 0 && *namepv == '%')
ad64d0ec 1271 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
6d5c2147
FC
1272 else if (namelen != 0 && *namepv == '&')
1273 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
b5c19bd7
DM
1274 else
1275 *out_capture = sv_newmortal();
1276 }
dd2155a4 1277 }
b5c19bd7
DM
1278
1279 return offset;
ee6cee0c 1280 }
b5c19bd7
DM
1281 }
1282
1283 /* it's not in this pad - try above */
1284
1285 if (!CvOUTSIDE(cv))
1286 return NOT_IN_PAD;
9f7d9405 1287
b5c19bd7 1288 /* out_capture non-null means caller wants us to capture lex; in
71f882da 1289 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 1290 new_capturep = out_capture ? out_capture :
4608196e 1291 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7 1292
7ef30830
FC
1293 offset = pad_findlex(namepv, namelen,
1294 flags | padadd_STALEOK*(new_capturep == &new_capture),
1295 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
e1c02f84 1296 new_capturep, out_name, out_flags);
9f7d9405 1297 if ((PADOFFSET)offset == NOT_IN_PAD)
b5c19bd7 1298 return NOT_IN_PAD;
9f7d9405 1299
b5c19bd7
DM
1300 /* found in an outer CV. Add appropriate fake entry to this pad */
1301
1302 /* don't add new fake entries (via eval) to CVs that we have already
1303 * finished compiling, or to undef CVs */
1304 if (CvCOMPILED(cv) || !padlist)
1305 return 0; /* this dummy (and invalid) value isnt used by the caller */
1306
1307 {
3291825f 1308 /* This relies on sv_setsv_flags() upgrading the destination to the same
486ec47a 1309 type as the source, independent of the flags set, and on it being
3291825f
NC
1310 "good" and only copying flag bits and pointers that it understands.
1311 */
0f94cb1f 1312 PADNAME *new_name = newPADNAMEouter(*out_name);
9b7476d7 1313 PADNAMELIST * const ocomppad_name = PL_comppad_name;
53c1dcc0 1314 PAD * const ocomppad = PL_comppad;
9b7476d7 1315 PL_comppad_name = PadlistNAMES(padlist);
86d2498c 1316 PL_comppad = PadlistARRAY(padlist)[1];
b5c19bd7
DM
1317 PL_curpad = AvARRAY(PL_comppad);
1318
3291825f 1319 new_offset
e1c02f84
FC
1320 = pad_alloc_name(new_name,
1321 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1322 PadnameTYPE(*out_name),
1323 PadnameOURSTASH(*out_name)
3291825f
NC
1324 );
1325
3291825f
NC
1326 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1327 "Pad addname: %ld \"%.*s\" FAKE\n",
1328 (long)new_offset,
e1c02f84
FC
1329 (int) PadnameLEN(new_name),
1330 PadnamePV(new_name)));
1331 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
b5c19bd7 1332
e1c02f84
FC
1333 PARENT_PAD_INDEX_set(new_name, 0);
1334 if (PadnameIsOUR(new_name)) {
6f207bd3 1335 NOOP; /* do nothing */
b5c19bd7 1336 }
71f882da 1337 else if (CvLATE(cv)) {
b5c19bd7 1338 /* delayed creation - just note the offset within parent pad */
e1c02f84 1339 PARENT_PAD_INDEX_set(new_name, offset);
b5c19bd7
DM
1340 CvCLONE_on(cv);
1341 }
1342 else {
1343 /* immediate creation - capture outer value right now */
1344 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
81df9f6f 1345 /* But also note the offset, as newMYSUB needs it */
e1c02f84 1346 PARENT_PAD_INDEX_set(new_name, offset);
b5c19bd7
DM
1347 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1348 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1349 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 1350 }
e1c02f84
FC
1351 *out_name = new_name;
1352 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
b5c19bd7
DM
1353
1354 PL_comppad_name = ocomppad_name;
1355 PL_comppad = ocomppad;
4608196e 1356 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 1357 }
b5c19bd7 1358 return new_offset;
dd2155a4
DM
1359}
1360
fb8a9836 1361#ifdef DEBUGGING
cc76b5cc 1362
dd2155a4 1363/*
cc76b5cc 1364=for apidoc Am|SV *|pad_sv|PADOFFSET po
dd2155a4 1365
cc76b5cc 1366Get the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1367Use macro PAD_SV instead of calling this function directly.
1368
1369=cut
1370*/
1371
dd2155a4
DM
1372SV *
1373Perl_pad_sv(pTHX_ PADOFFSET po)
1374{
f3548bdc 1375 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 1376
dd2155a4
DM
1377 if (!po)
1378 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
1379 DEBUG_X(PerlIO_printf(Perl_debug_log,
1380 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 1381 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
1382 );
1383 return PL_curpad[po];
1384}
1385
dd2155a4 1386/*
cc76b5cc 1387=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
dd2155a4 1388
cc76b5cc 1389Set the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1390Use the macro PAD_SETSV() rather than calling this function directly.
1391
1392=cut
1393*/
1394
dd2155a4
DM
1395void
1396Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1397{
7918f24d
NC
1398 PERL_ARGS_ASSERT_PAD_SETSV;
1399
f3548bdc 1400 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
1401
1402 DEBUG_X(PerlIO_printf(Perl_debug_log,
1403 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 1404 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
1405 );
1406 PL_curpad[po] = sv;
1407}
dd2155a4 1408
cc76b5cc 1409#endif /* DEBUGGING */
dd2155a4
DM
1410
1411/*
cc76b5cc 1412=for apidoc m|void|pad_block_start|int full
dd2155a4 1413
e89fca5e 1414Update the pad compilation state variables on entry to a new block.
dd2155a4
DM
1415
1416=cut
1417*/
1418
1419/* XXX DAPM perhaps:
1420 * - integrate this in general state-saving routine ???
1421 * - combine with the state-saving going on in pad_new ???
1422 * - introduce a new SAVE type that does all this in one go ?
1423 */
1424
1425void
1426Perl_pad_block_start(pTHX_ int full)
1427{
f3548bdc 1428 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4 1429 SAVEI32(PL_comppad_name_floor);
9b7476d7 1430 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
dd2155a4
DM
1431 if (full)
1432 PL_comppad_name_fill = PL_comppad_name_floor;
1433 if (PL_comppad_name_floor < 0)
1434 PL_comppad_name_floor = 0;
1435 SAVEI32(PL_min_intro_pending);
1436 SAVEI32(PL_max_intro_pending);
1437 PL_min_intro_pending = 0;
1438 SAVEI32(PL_comppad_name_fill);
1439 SAVEI32(PL_padix_floor);
1780e744
FC
1440 /* PL_padix_floor is what PL_padix is reset to at the start of each
1441 statement, by pad_reset(). We set it when entering a new scope
1442 to keep things like this working:
1443 print "$foo$bar", do { this(); that() . "foo" };
1444 We must not let "$foo$bar" and the later concatenation share the
1445 same target. */
dd2155a4
DM
1446 PL_padix_floor = PL_padix;
1447 PL_pad_reset_pending = FALSE;
1448}
1449
dd2155a4 1450/*
25f5d540 1451=for apidoc Am|U32|intro_my
dd2155a4 1452
25f5d540
LM
1453"Introduce" C<my> variables to visible status. This is called during parsing
1454at the end of each statement to make lexical variables visible to subsequent
1455statements.
dd2155a4
DM
1456
1457=cut
1458*/
1459
1460U32
1461Perl_intro_my(pTHX)
1462{
6a0435be 1463 PADNAME **svp;
dd2155a4 1464 I32 i;
6012dc80 1465 U32 seq;
dd2155a4 1466
f3548bdc 1467 ASSERT_CURPAD_ACTIVE("intro_my");
8635e3c2
FC
1468 if (PL_compiling.cop_seq) {
1469 seq = PL_compiling.cop_seq;
1470 PL_compiling.cop_seq = 0;
1471 }
1472 else
1473 seq = PL_cop_seqmax;
dd2155a4 1474 if (! PL_min_intro_pending)
8635e3c2 1475 return seq;
dd2155a4 1476
9b7476d7 1477 svp = PadnamelistARRAY(PL_comppad_name);
dd2155a4 1478 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
6a0435be 1479 PADNAME * const sv = svp[i];
53c1dcc0 1480
6a0435be 1481 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
0d311cdb
DM
1482 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1483 {
2df5bdd7 1484 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
809abb02 1485 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1486 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1487 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
6a0435be 1488 (long)i, PadnamePV(sv),
809abb02
NC
1489 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1490 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1491 );
1492 }
1493 }
953c8b80 1494 COP_SEQMAX_INC;
dd2155a4
DM
1495 PL_min_intro_pending = 0;
1496 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1497 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
6012dc80 1498 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
dd2155a4 1499
6012dc80 1500 return seq;
dd2155a4
DM
1501}
1502
1503/*
cc76b5cc 1504=for apidoc m|void|pad_leavemy
dd2155a4
DM
1505
1506Cleanup at end of scope during compilation: set the max seq number for
1507lexicals in this scope and warn of any lexicals that never got introduced.
1508
1509=cut
1510*/
1511
6d5c2147 1512OP *
dd2155a4
DM
1513Perl_pad_leavemy(pTHX)
1514{
1515 I32 off;
6d5c2147 1516 OP *o = NULL;
9b7476d7 1517 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
dd2155a4
DM
1518
1519 PL_pad_reset_pending = FALSE;
1520
f3548bdc 1521 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1522 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1523 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
01b9977c
FC
1524 const PADNAME * const name = svp[off];
1525 if (name && PadnameLEN(name) && !PadnameOUTER(name))
9b387841 1526 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
01b9977c
FC
1527 "%"PNf" never introduced",
1528 PNfARG(name));
dd2155a4
DM
1529 }
1530 }
1531 /* "Deintroduce" my variables that are leaving with this scope. */
9b7476d7
FC
1532 for (off = PadnamelistMAX(PL_comppad_name);
1533 off > PL_comppad_name_fill; off--) {
01b9977c
FC
1534 PADNAME * const sv = svp[off];
1535 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
2df5bdd7
DM
1536 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1537 {
809abb02 1538 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
dd2155a4 1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1540 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
01b9977c 1541 (long)off, PadnamePV(sv),
809abb02
NC
1542 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1543 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4 1544 );
6d5c2147
FC
1545 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1546 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1547 OP *kid = newOP(OP_INTROCV, 0);
1548 kid->op_targ = off;
1549 o = op_prepend_elem(OP_LINESEQ, kid, o);
1550 }
dd2155a4
DM
1551 }
1552 }
953c8b80 1553 COP_SEQMAX_INC;
dd2155a4
DM
1554 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1555 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
6d5c2147 1556 return o;
dd2155a4
DM
1557}
1558
dd2155a4 1559/*
cc76b5cc 1560=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
dd2155a4
DM
1561
1562Abandon the tmp in the current pad at offset po and replace with a
1563new one.
1564
1565=cut
1566*/
1567
1568void
1569Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1570{
f3548bdc 1571 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1572 if (!PL_curpad)
1573 return;
1574 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1575 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1576 AvARRAY(PL_comppad), PL_curpad);
9100eeb1
Z
1577 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1578 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1579 (long)po, (long)AvFILLp(PL_comppad));
dd2155a4
DM
1580
1581 DEBUG_X(PerlIO_printf(Perl_debug_log,
1582 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1583 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1584
dd2155a4
DM
1585 if (refadjust)
1586 SvREFCNT_dec(PL_curpad[po]);
1587
9ad9869c
DM
1588
1589 /* if pad tmps aren't shared between ops, then there's no need to
1590 * create a new tmp when an existing op is freed */
53de1311 1591#ifdef USE_PAD_RESET
561b68a9 1592 PL_curpad[po] = newSV(0);
dd2155a4 1593 SvPADTMP_on(PL_curpad[po]);
9ad9869c 1594#else
ce0d59fd 1595 PL_curpad[po] = NULL;
97bf4a8d 1596#endif
325e1816 1597 if (PadnamelistMAX(PL_comppad_name) != -1
4891fdfa 1598 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
ce0d59fd
FC
1599 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1600 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1601 }
0f94cb1f 1602 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
325e1816 1603 }
b54c5e14
FC
1604 /* Use PL_constpadix here, not PL_padix. The latter may have been
1605 reset by pad_reset. We don’t want pad_alloc to have to scan the
1606 whole pad when allocating a constant. */
1607 if ((I32)po < PL_constpadix)
1608 PL_constpadix = po - 1;
dd2155a4
DM
1609}
1610
dd2155a4 1611/*
cc76b5cc 1612=for apidoc m|void|pad_reset
dd2155a4
DM
1613
1614Mark all the current temporaries for reuse
1615
1616=cut
1617*/
1618
1780e744
FC
1619/* pad_reset() causes pad temp TARGs (operator targets) to be shared
1620 * between OPs from different statements. During compilation, at the start
1621 * of each statement pad_reset resets PL_padix back to its previous value.
1622 * When allocating a target, pad_alloc begins its scan through the pad at
1623 * PL_padix+1. */
1f676739 1624static void
82af08ae 1625S_pad_reset(pTHX)
dd2155a4 1626{
53de1311 1627#ifdef USE_PAD_RESET
dd2155a4 1628 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1629 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1630 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1631
1632 DEBUG_X(PerlIO_printf(Perl_debug_log,
1633 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1634 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1635 (long)PL_padix, (long)PL_padix_floor
1636 )
1637 );
1638
284167a5 1639 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
dd2155a4
DM
1640 PL_padix = PL_padix_floor;
1641 }
1642#endif
1643 PL_pad_reset_pending = FALSE;
1644}
1645
dd2155a4 1646/*
cc76b5cc
Z
1647=for apidoc Amx|void|pad_tidy|padtidy_type type
1648
1649Tidy up a pad at the end of compilation of the code to which it belongs.
1650Jobs performed here are: remove most stuff from the pads of anonsub
1651prototypes; give it a @_; mark temporaries as such. I<type> indicates
1652the kind of subroutine:
dd2155a4 1653
cc76b5cc
Z
1654 padtidy_SUB ordinary subroutine
1655 padtidy_SUBCLONE prototype for lexical closure
1656 padtidy_FORMAT format
dd2155a4
DM
1657
1658=cut
1659*/
1660
1661/* XXX DAPM surely most of this stuff should be done properly
1662 * at the right time beforehand, rather than going around afterwards
1663 * cleaning up our mistakes ???
1664 */
1665
1666void
1667Perl_pad_tidy(pTHX_ padtidy_type type)
1668{
27da23d5 1669 dVAR;
dd2155a4 1670
f3548bdc 1671 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7 1672
db21619c
DM
1673 /* If this CV has had any 'eval-capable' ops planted in it:
1674 * i.e. it contains any of:
1675 *
1676 * * eval '...',
1677 * * //ee,
1678 * * use re 'eval'; /$var/
1679 * * /(?{..})/),
1680 *
1681 * Then any anon prototypes in the chain of CVs should be marked as
1682 * cloneable, so that for example the eval's CV in
1683 *
1684 * sub { eval '$x' }
1685 *
1686 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1687 * potentially have an eval executed within it.
b5c19bd7
DM
1688 */
1689
1690 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1691 const CV *cv;
b5c19bd7
DM
1692 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1693 if (cv != PL_compcv && CvCOMPILED(cv))
1694 break; /* no need to mark already-compiled code */
1695 if (CvANON(cv)) {
1696 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1697 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1698 CvCLONE_on(cv);
1699 }
00cc8743 1700 CvHASEVAL_on(cv);
b5c19bd7
DM
1701 }
1702 }
1703
eb8137a9 1704 /* extend namepad to match curpad */
9b7476d7
FC
1705 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1706 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1707
1708 if (type == padtidy_SUBCLONE) {
9b7476d7 1709 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1710 PADOFFSET ix;
b5c19bd7 1711
dd2155a4 1712 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
dbfcda05
FC
1713 PADNAME *namesv;
1714 if (!namep[ix]) namep[ix] = &PL_padname_undef;
dd2155a4 1715
dd2155a4
DM
1716 /*
1717 * The only things that a clonable function needs in its
3a6ce63a 1718 * pad are anonymous subs, constants and GVs.
dd2155a4
DM
1719 * The rest are created anew during cloning.
1720 */
b561f196 1721 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
3a6ce63a 1722 continue;
ce0d59fd
FC
1723 namesv = namep[ix];
1724 if (!(PadnamePV(namesv) &&
dbfcda05 1725 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
dd2155a4
DM
1726 {
1727 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1728 PL_curpad[ix] = NULL;
dd2155a4
DM
1729 }
1730 }
1731 }
1732 else if (type == padtidy_SUB) {
1733 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
53c1dcc0 1734 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1735 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1736 AvREIFY_only(av);
dd2155a4
DM
1737 }
1738
4cee4ca8 1739 if (type == padtidy_SUB || type == padtidy_FORMAT) {
9b7476d7 1740 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1741 PADOFFSET ix;
dd2155a4 1742 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
0f94cb1f 1743 if (!namep[ix]) namep[ix] = &PL_padname_undef;
2347c8c0 1744 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
dd2155a4 1745 continue;
0f94cb1f 1746 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
adf8f095
NC
1747 /* This is a work around for how the current implementation of
1748 ?{ } blocks in regexps interacts with lexicals.
1749
1750 One of our lexicals.
1751 Can't do this on all lexicals, otherwise sub baz() won't
1752 compile in
1753
1754 my $foo;
1755
1756 sub bar { ++$foo; }
1757
1758 sub baz { ++$foo; }
1759
1760 because completion of compiling &bar calling pad_tidy()
1761 would cause (top level) $foo to be marked as stale, and
1762 "no longer available". */
1763 SvPADSTALE_on(PL_curpad[ix]);
1764 }
dd2155a4
DM
1765 }
1766 }
f3548bdc 1767 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1768}
1769
dd2155a4 1770/*
cc76b5cc 1771=for apidoc m|void|pad_free|PADOFFSET po
dd2155a4 1772
8627550a 1773Free the SV at offset po in the current pad.
dd2155a4
DM
1774
1775=cut
1776*/
1777
1778/* XXX DAPM integrate with pad_swipe ???? */
1779void
1780Perl_pad_free(pTHX_ PADOFFSET po)
1781{
53de1311 1782#ifndef USE_PAD_RESET
ad9e6ae1 1783 SV *sv;
ff06c6b2 1784#endif
f3548bdc 1785 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1786 if (!PL_curpad)
1787 return;
1788 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1789 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1790 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1791 if (!po)
1792 Perl_croak(aTHX_ "panic: pad_free po");
1793
1794 DEBUG_X(PerlIO_printf(Perl_debug_log,
1795 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1796 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1797 );
1798
53de1311 1799#ifndef USE_PAD_RESET
ad9e6ae1
DM
1800 sv = PL_curpad[po];
1801 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1802 SvFLAGS(sv) &= ~SVs_PADTMP;
1803
dd2155a4
DM
1804 if ((I32)po < PL_padix)
1805 PL_padix = po - 1;
53d3c048 1806#endif
dd2155a4
DM
1807}
1808
dd2155a4 1809/*
cc76b5cc 1810=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
dd2155a4
DM
1811
1812Dump the contents of a padlist
1813
1814=cut
1815*/
1816
1817void
1818Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1819{
9b7476d7 1820 const PADNAMELIST *pad_name;
e1ec3a88 1821 const AV *pad;
01326933 1822 PADNAME **pname;
dd2155a4 1823 SV **ppad;
dd2155a4
DM
1824 I32 ix;
1825
7918f24d
NC
1826 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1827
dd2155a4
DM
1828 if (!padlist) {
1829 return;
1830 }
9b7476d7 1831 pad_name = PadlistNAMES(padlist);
86d2498c 1832 pad = PadlistARRAY(padlist)[1];
9b7476d7 1833 pname = PadnamelistARRAY(pad_name);
dd2155a4
DM
1834 ppad = AvARRAY(pad);
1835 Perl_dump_indent(aTHX_ level, file,
1836 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1837 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1838 );
1839
9b7476d7 1840 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
01326933 1841 const PADNAME *namesv = pname[ix];
325e1816 1842 if (namesv && !PadnameLEN(namesv)) {
a0714e2c 1843 namesv = NULL;
dd2155a4
DM
1844 }
1845 if (namesv) {
01326933 1846 if (PadnameOUTER(namesv))
ee6cee0c 1847 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1848 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1849 (int) ix,
1850 PTR2UV(ppad[ix]),
1851 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
01326933 1852 PadnamePV(namesv),
809abb02
NC
1853 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1854 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1855
ee6cee0c
DM
1856 );
1857 else
1858 Perl_dump_indent(aTHX_ level+1, file,
809abb02 1859 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1860 (int) ix,
1861 PTR2UV(ppad[ix]),
1862 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1863 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1864 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
01326933 1865 PadnamePV(namesv)
ee6cee0c 1866 );
dd2155a4
DM
1867 }
1868 else if (full) {
1869 Perl_dump_indent(aTHX_ level+1, file,
1870 "%2d. 0x%"UVxf"<%lu>\n",
1871 (int) ix,
1872 PTR2UV(ppad[ix]),
1873 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1874 );
1875 }
1876 }
1877}
1878
cc76b5cc 1879#ifdef DEBUGGING
dd2155a4
DM
1880
1881/*
cc76b5cc 1882=for apidoc m|void|cv_dump|CV *cv|const char *title
dd2155a4
DM
1883
1884dump the contents of a CV
1885
1886=cut
1887*/
1888
dd2155a4 1889STATIC void
e1ec3a88 1890S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1891{
53c1dcc0 1892 const CV * const outside = CvOUTSIDE(cv);
b70d5558 1893 PADLIST* const padlist = CvPADLIST(cv);
dd2155a4 1894
7918f24d
NC
1895 PERL_ARGS_ASSERT_CV_DUMP;
1896
dd2155a4
DM
1897 PerlIO_printf(Perl_debug_log,
1898 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1899 title,
1900 PTR2UV(cv),
1901 (CvANON(cv) ? "ANON"
71f882da 1902 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1903 : (cv == PL_main_cv) ? "MAIN"
1904 : CvUNIQUE(cv) ? "UNIQUE"
1905 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1906 PTR2UV(outside),
1907 (!outside ? "null"
1908 : CvANON(outside) ? "ANON"
1909 : (outside == PL_main_cv) ? "MAIN"
1910 : CvUNIQUE(outside) ? "UNIQUE"
1911 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1912
1913 PerlIO_printf(Perl_debug_log,
1914 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1915 do_dump_pad(1, Perl_debug_log, padlist, 1);
1916}
dd2155a4 1917
cc76b5cc 1918#endif /* DEBUGGING */
dd2155a4
DM
1919
1920/*
cc76b5cc 1921=for apidoc Am|CV *|cv_clone|CV *proto
dd2155a4 1922
cc76b5cc
Z
1923Clone a CV, making a lexical closure. I<proto> supplies the prototype
1924of the function: its code, pad structure, and other attributes.
1925The prototype is combined with a capture of outer lexicals to which the
1926code refers, which are taken from the currently-executing instance of
1927the immediately surrounding code.
dd2155a4
DM
1928
1929=cut
1930*/
1931
e10681aa
FC
1932static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1933
21195f4d 1934static CV *
5fab0186 1935S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
dd2155a4 1936{
dd2155a4 1937 I32 ix;
b70d5558 1938 PADLIST* const protopadlist = CvPADLIST(proto);
9b7476d7 1939 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
86d2498c 1940 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
39899bf0 1941 PADNAME** const pname = PadnamelistARRAY(protopad_name);
53c1dcc0 1942 SV** const ppad = AvARRAY(protopad);
9b7476d7 1943 const I32 fname = PadnamelistMAX(protopad_name);
e1ec3a88 1944 const I32 fpad = AvFILLp(protopad);
b5c19bd7 1945 SV** outpad;
71f882da 1946 long depth;
e07561e6 1947 bool subclones = FALSE;
7918f24d 1948
dd2155a4
DM
1949 assert(!CvUNIQUE(proto));
1950
1b5aaca6
FC
1951 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1952 * reliable. The currently-running sub is always the one we need to
1953 * close over.
8d88fe29
FC
1954 * For my subs, the currently-running sub may not be the one we want.
1955 * We have to check whether it is a clone of CvOUTSIDE.
1b5aaca6
FC
1956 * Note that in general for formats, CvOUTSIDE != find_runcv.
1957 * Since formats may be nested inside closures, CvOUTSIDE may point
71f882da 1958 * to a prototype; we instead want the cloned parent who called us.
af41786f 1959 */
71f882da 1960
e07561e6 1961 if (!outside) {
ebfebee4 1962 if (CvWEAKOUTSIDE(proto))
71f882da 1963 outside = find_runcv(NULL);
e07561e6 1964 else {
af41786f 1965 outside = CvOUTSIDE(proto);
db4cf31d
FC
1966 if ((CvCLONE(outside) && ! CvCLONED(outside))
1967 || !CvPADLIST(outside)
b4db5868 1968 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
db4cf31d 1969 outside = find_runcv_where(
a56015b9 1970 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
70794f7b 1971 );
db4cf31d 1972 /* outside could be null */
5dff782d 1973 }
e07561e6 1974 }
5dff782d 1975 }
db4cf31d 1976 depth = outside ? CvDEPTH(outside) : 0;
71f882da
DM
1977 if (!depth)
1978 depth = 1;
b5c19bd7 1979
dd2155a4
DM
1980 ENTER;
1981 SAVESPTR(PL_compcv);
e07561e6 1982 PL_compcv = cv;
5fab0186 1983 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
dd2155a4 1984
a0d2bbd5
FC
1985 if (CvHASEVAL(cv))
1986 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
dd2155a4 1987
cbacc9aa 1988 SAVESPTR(PL_comppad_name);
9ef8d569 1989 PL_comppad_name = protopad_name;
eacbb379 1990 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
b4db5868 1991 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
dd2155a4 1992
b5c19bd7 1993 av_fill(PL_comppad, fpad);
dd2155a4 1994
dd2155a4
DM
1995 PL_curpad = AvARRAY(PL_comppad);
1996
db4cf31d 1997 outpad = outside && CvPADLIST(outside)
86d2498c 1998 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
f2ead8b8 1999 : NULL;
b4db5868 2000 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
b5c19bd7 2001
dd2155a4 2002 for (ix = fpad; ix > 0; ix--) {
39899bf0 2003 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
a0714e2c 2004 SV *sv = NULL;
325e1816 2005 if (namesv && PadnameLEN(namesv)) { /* lexical */
f2047bf1
FC
2006 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2007 NOOP;
2008 }
2009 else {
39899bf0 2010 if (PadnameOUTER(namesv)) { /* lexical from outside? */
5aec98df
FC
2011 /* formats may have an inactive, or even undefined, parent;
2012 but state vars are always available. */
f2ead8b8 2013 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
cae5dbbe 2014 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
db4cf31d 2015 && (!outside || !CvDEPTH(outside))) ) {
445f13ff 2016 S_unavailable(aTHX_ namesv);
a0714e2c 2017 sv = NULL;
71f882da 2018 }
33894c1a 2019 else
f84c484e 2020 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 2021 }
71f882da 2022 if (!sv) {
39899bf0 2023 const char sigil = PadnamePV(namesv)[0];
e1ec3a88 2024 if (sigil == '&')
e07561e6
FC
2025 /* If there are state subs, we need to clone them, too.
2026 But they may need to close over variables we have
2027 not cloned yet. So we will have to do a second
2028 pass. Furthermore, there may be state subs clos-
2029 ing over other state subs’ entries, so we have
2030 to put a stub here and then clone into it on the
2031 second pass. */
6d5c2147
FC
2032 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2033 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2034 subclones = 1;
2035 sv = newSV_type(SVt_PVCV);
f3feca7a 2036 CvLEXICAL_on(sv);
6d5c2147
FC
2037 }
2038 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2039 {
2040 /* my sub */
81df9f6f
FC
2041 /* Just provide a stub, but name it. It will be
2042 upgrade to the real thing on scope entry. */
f7cf2d13 2043 dVAR;
e1588866 2044 U32 hash;
39899bf0
FC
2045 PERL_HASH(hash, PadnamePV(namesv)+1,
2046 PadnameLEN(namesv) - 1);
81df9f6f 2047 sv = newSV_type(SVt_PVCV);
cf748c3c
FC
2048 CvNAME_HEK_set(
2049 sv,
39899bf0
FC
2050 share_hek(PadnamePV(namesv)+1,
2051 1 - PadnameLEN(namesv),
e1588866 2052 hash)
cf748c3c 2053 );
f3feca7a 2054 CvLEXICAL_on(sv);
6d5c2147
FC
2055 }
2056 else sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 2057 else if (sigil == '@')
ad64d0ec 2058 sv = MUTABLE_SV(newAV());
e1ec3a88 2059 else if (sigil == '%')
ad64d0ec 2060 sv = MUTABLE_SV(newHV());
dd2155a4 2061 else
561b68a9 2062 sv = newSV(0);
0d3b281c 2063 /* reset the 'assign only once' flag on each state var */
e07561e6 2064 if (sigil != '&' && SvPAD_STATE(namesv))
0d3b281c 2065 SvPADSTALE_on(sv);
dd2155a4 2066 }
f2047bf1 2067 }
dd2155a4 2068 }
4c894bf7 2069 else if (namesv && PadnamePV(namesv)) {
f84c484e 2070 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
2071 }
2072 else {
561b68a9 2073 sv = newSV(0);
dd2155a4 2074 SvPADTMP_on(sv);
dd2155a4 2075 }
71f882da 2076 PL_curpad[ix] = sv;
dd2155a4
DM
2077 }
2078
e07561e6
FC
2079 if (subclones)
2080 for (ix = fpad; ix > 0; ix--) {
39899bf0
FC
2081 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2082 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2083 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
e07561e6
FC
2084 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2085 }
2086
5fab0186 2087 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
e10681aa 2088 LEAVE;
21195f4d 2089
1567c65a
FC
2090 if (CvCONST(cv)) {
2091 /* Constant sub () { $x } closing over $x:
2092 * The prototype was marked as a candiate for const-ization,
2093 * so try to grab the current const value, and if successful,
2094 * turn into a const sub:
2095 */
d8d6ddf8
FC
2096 SV* const_sv;
2097 OP *o = CvSTART(cv);
1567c65a 2098 assert(newcv);
d8d6ddf8
FC
2099 for (; o; o = o->op_next)
2100 if (o->op_type == OP_PADSV)
2101 break;
2102 ASSUME(o->op_type == OP_PADSV);
2103 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2104 /* the candidate should have 1 ref from this pad and 1 ref
2105 * from the parent */
2106 if (const_sv && SvREFCNT(const_sv) == 2) {
1567c65a 2107 const bool was_method = cBOOL(CvMETHOD(cv));
04472a84 2108 bool copied = FALSE;
d8d6ddf8
FC
2109 if (outside) {
2110 PADNAME * const pn =
2111 PadlistNAMESARRAY(CvPADLIST(outside))
2112 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2113 CvPADLIST(cv))[o->op_targ])];
2114 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2115 [o->op_targ]));
2116 if (PadnameLVALUE(pn)) {
2117 /* We have a lexical that is potentially modifiable
2118 elsewhere, so making a constant will break clo-
2119 sure behaviour. If this is a ‘simple lexical
2120 op tree’, i.e., sub(){$x}, emit a deprecation
2121 warning, but continue to exhibit the old behav-
2122 iour of making it a constant based on the ref-
2123 count of the candidate variable.
2124
2125 A simple lexical op tree looks like this:
2126
2127 leavesub
2128 lineseq
2129 nextstate
2130 padsv
2131 */
2132 if (OP_SIBLING(
2133 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2134 ) == o
2135 && !OP_SIBLING(o))
04472a84 2136 {
d8d6ddf8
FC
2137 Perl_ck_warner_d(aTHX_
2138 packWARN(WARN_DEPRECATED),
2139 "Constants from lexical "
2140 "variables potentially "
2141 "modified elsewhere are "
2142 "deprecated");
04472a84
FC
2143 /* We *copy* the lexical variable, and donate the
2144 copy to newCONSTSUB. Yes, this is ugly, and
2145 should be killed. We need to do this for the
2146 time being, however, because turning on SvPADTMP
2147 on a lexical will have observable effects
2148 elsewhere. */
2149 const_sv = newSVsv(const_sv);
2150 copied = TRUE;
2151 }
d8d6ddf8
FC
2152 else
2153 goto constoff;
2154 }
2155 }
04472a84
FC
2156 if (!copied)
2157 SvREFCNT_inc_simple_void_NN(const_sv);
2158 /* If the lexical is not used elsewhere, it is safe to turn on
2159 SvPADTMP, since it is only when it is used in lvalue con-
2160 text that the difference is observable. */
6dfba0aa 2161 SvREADONLY_on(const_sv);
d8d6ddf8 2162 SvPADTMP_on(const_sv);
1567c65a 2163 SvREFCNT_dec_NN(cv);
1567c65a
FC
2164 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2165 if (was_method)
2166 CvMETHOD_on(cv);
2167 }
2168 else {
d8d6ddf8 2169 constoff:
1567c65a
FC
2170 CvCONST_off(cv);
2171 }
2172 }
2173
21195f4d 2174 return cv;
e10681aa
FC
2175}
2176
2177static CV *
2178S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2179{
20b7effb 2180#ifdef USE_ITHREADS
c04ef36e 2181 dVAR;
20b7effb 2182#endif
5fab0186 2183 const bool newcv = !cv;
c04ef36e 2184
e10681aa
FC
2185 assert(!CvUNIQUE(proto));
2186
2187 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2188 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2189 |CVf_SLABBED);
2190 CvCLONED_on(cv);
2191
2192 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2193 : CvFILE(proto);
2194 if (CvNAMED(proto))
2e800d79 2195 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
e10681aa
FC
2196 else CvGV_set(cv,CvGV(proto));
2197 CvSTASH_set(cv, CvSTASH(proto));
2198 OP_REFCNT_LOCK;
2199 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2200 OP_REFCNT_UNLOCK;
2201 CvSTART(cv) = CvSTART(proto);
2202 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2203
fdf416b6 2204 if (SvPOK(proto)) {
e10681aa 2205 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
fdf416b6
BF
2206 if (SvUTF8(proto))
2207 SvUTF8_on(MUTABLE_SV(cv));
2208 }
e10681aa
FC
2209 if (SvMAGIC(proto))
2210 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2211
21195f4d
FC
2212 if (CvPADLIST(proto))
2213 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
e10681aa 2214
dd2155a4
DM
2215 DEBUG_Xv(
2216 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
e10681aa 2217 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
dd2155a4
DM
2218 cv_dump(proto, "Proto");
2219 cv_dump(cv, "To");
2220 );
2221
dd2155a4
DM
2222 return cv;
2223}
2224
e07561e6
FC
2225CV *
2226Perl_cv_clone(pTHX_ CV *proto)
2227{
2228 PERL_ARGS_ASSERT_CV_CLONE;
2229
fead5351 2230 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
e07561e6
FC
2231 return S_cv_clone(aTHX_ proto, NULL, NULL);
2232}
2233
6d5c2147
FC
2234/* Called only by pp_clonecv */
2235CV *
2236Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2237{
2238 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2239 cv_undef(target);
2240 return S_cv_clone(aTHX_ proto, target, NULL);
2241}
2242
fb094047
FC
2243/*
2244=for apidoc cv_name
2245
2246Returns an SV containing the name of the CV, mainly for use in error
2247reporting. The CV may actually be a GV instead, in which case the returned
7a275a2e
FC
2248SV holds the GV's name. Anything other than a GV or CV is treated as a
2249string already holding the sub name, but this could change in the future.
fb094047
FC
2250
2251An SV may be passed as a second argument. If so, the name will be assigned
2252to it and it will be returned. Otherwise the returned SV will be a new
2253mortal.
2254
ecf05a58
FC
2255If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2256included. If the first argument is neither a CV nor a GV, this flag is
2257ignored (subject to change).
2258
fb094047
FC
2259=cut
2260*/
2261
c5569a55 2262SV *
ecf05a58 2263Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
c5569a55
FC
2264{
2265 PERL_ARGS_ASSERT_CV_NAME;
2266 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2267 if (sv) sv_setsv(sv,(SV *)cv);
2268 return sv ? (sv) : (SV *)cv;
2269 }
2270 {
f3fb6cf3 2271 SV * const retsv = sv ? (sv) : sv_newmortal();
c5569a55
FC
2272 if (SvTYPE(cv) == SVt_PVCV) {
2273 if (CvNAMED(cv)) {
ecf05a58
FC
2274 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2275 sv_sethek(retsv, CvNAME_HEK(cv));
c5569a55
FC
2276 else {
2277 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2278 sv_catpvs(retsv, "::");
f34d8cdd 2279 sv_cathek(retsv, CvNAME_HEK(cv));
c5569a55
FC
2280 }
2281 }
ecf05a58 2282 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
c5569a55
FC
2283 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2284 else gv_efullname3(retsv, CvGV(cv), NULL);
2285 }
ecf05a58 2286 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
c5569a55
FC
2287 else gv_efullname3(retsv,(GV *)cv,NULL);
2288 return retsv;
2289 }
2290}
2291
dd2155a4 2292/*
cc76b5cc 2293=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
dd2155a4
DM
2294
2295For any anon CVs in the pad, change CvOUTSIDE of that CV from
72d33970 2296old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
7dafbf52 2297moved to a pre-existing CV struct.
dd2155a4
DM
2298
2299=cut
2300*/
2301
2302void
2303Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2304{
2305 I32 ix;
9b7476d7 2306 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
86d2498c 2307 AV * const comppad = PadlistARRAY(padlist)[1];
0f94cb1f 2308 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
53c1dcc0 2309 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
2310
2311 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
2312 PERL_UNUSED_ARG(old_cv);
2313
9b7476d7 2314 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
0f94cb1f
FC
2315 const PADNAME * const name = namepad[ix];
2316 if (name && name != &PL_padname_undef && !PadnameIsSTATE(name)
2317 && *PadnamePV(name) == '&')
dd2155a4 2318 {
e09ac076 2319 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
0f94cb1f
FC
2320 /* XXX 0afba48f added code here to check for a proto CV
2321 attached to the pad entry by magic. But shortly there-
2322 after 81df9f6f95 moved the magic to the pad name. The
2323 code here was never updated, so it wasn’t doing anything
2324 and got deleted when PADNAME became a distinct type. Is
2325 there any bug as a result? */
2326 CV * const innercv = MUTABLE_CV(curpad[ix]);
0afba48f 2327 if (CvOUTSIDE(innercv) == old_cv) {
1f122f9b
FC
2328 if (!CvWEAKOUTSIDE(innercv)) {
2329 SvREFCNT_dec(old_cv);
2330 SvREFCNT_inc_simple_void_NN(new_cv);
2331 }
0afba48f
FC
2332 CvOUTSIDE(innercv) = new_cv;
2333 }
e09ac076
FC
2334 }
2335 else { /* format reference */
2336 SV * const rv = curpad[ix];
2337 CV *innercv;
2338 if (!SvOK(rv)) continue;
2339 assert(SvROK(rv));
2340 assert(SvWEAKREF(rv));
2341 innercv = (CV *)SvRV(rv);
2342 assert(!CvWEAKOUTSIDE(innercv));
2343 SvREFCNT_dec(CvOUTSIDE(innercv));
2344 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2345 }
dd2155a4
DM
2346 }
2347 }
2348}
2349
2350/*
cc76b5cc 2351=for apidoc m|void|pad_push|PADLIST *padlist|int depth
dd2155a4
DM
2352
2353Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
2354this depth, in which case don't bother creating a new one. Then give
2355the new pad an @_ in slot zero.
dd2155a4
DM
2356
2357=cut
2358*/
2359
2360void
26019298 2361Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2362{
7918f24d
NC
2363 PERL_ARGS_ASSERT_PAD_PUSH;
2364
86d2498c
FC
2365 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2366 PAD** const svp = PadlistARRAY(padlist);
44f8325f
AL
2367 AV* const newpad = newAV();
2368 SV** const oldpad = AvARRAY(svp[depth-1]);
502c6561 2369 I32 ix = AvFILLp((const AV *)svp[1]);
9b7476d7 2370 const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
a2ddd1d1 2371 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
26019298
AL
2372 AV *av;
2373
dd2155a4 2374 for ( ;ix > 0; ix--) {
325e1816 2375 if (names_fill >= ix && PadnameLEN(names[ix])) {
a2ddd1d1
FC
2376 const char sigil = PadnamePV(names[ix])[0];
2377 if (PadnameOUTER(names[ix])
2378 || PadnameIsSTATE(names[ix])
fda94784
RGS
2379 || sigil == '&')
2380 {
dd2155a4
DM
2381 /* outer lexical or anon code */
2382 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2383 }
2384 else { /* our own lexical */
26019298
AL
2385 SV *sv;
2386 if (sigil == '@')
ad64d0ec 2387 sv = MUTABLE_SV(newAV());
26019298 2388 else if (sigil == '%')
ad64d0ec 2389 sv = MUTABLE_SV(newHV());
dd2155a4 2390 else
561b68a9 2391 sv = newSV(0);
26019298 2392 av_store(newpad, ix, sv);
dd2155a4
DM
2393 }
2394 }
778f1807 2395 else if (PadnamePV(names[ix])) {
f84c484e 2396 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2397 }
2398 else {
2399 /* save temporaries on recursion? */
561b68a9 2400 SV * const sv = newSV(0);
26019298 2401 av_store(newpad, ix, sv);
dd2155a4
DM
2402 SvPADTMP_on(sv);
2403 }
2404 }
26019298 2405 av = newAV();
ad64d0ec 2406 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2407 AvREIFY_only(av);
26019298 2408
7261499d 2409 padlist_store(padlist, depth, newpad);
dd2155a4
DM
2410 }
2411}
b21dc031 2412
d5b1589c
NC
2413#if defined(USE_ITHREADS)
2414
2415# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2416
cc76b5cc 2417/*
b70d5558 2418=for apidoc padlist_dup
cc76b5cc
Z
2419
2420Duplicates a pad.
2421
2422=cut
2423*/
2424
b70d5558
FC
2425PADLIST *
2426Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
d5b1589c 2427{
7261499d
FC
2428 PADLIST *dstpad;
2429 bool cloneall;
2430 PADOFFSET max;
2431
d5b1589c
NC
2432 PERL_ARGS_ASSERT_PADLIST_DUP;
2433
09c676d9 2434 cloneall = param->flags & CLONEf_COPY_STACKS;
86d2498c 2435 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
7261499d 2436
86d2498c 2437 max = cloneall ? PadlistMAX(srcpad) : 1;
7261499d
FC
2438
2439 Newx(dstpad, 1, PADLIST);
2440 ptr_table_store(PL_ptr_table, srcpad, dstpad);
86d2498c
FC
2441 PadlistMAX(dstpad) = max;
2442 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
7261499d 2443
9b7476d7
FC
2444 PadlistARRAY(dstpad)[0] = (PAD *)
2445 padnamelist_dup(PadlistNAMES(srcpad), param);
2446 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
7261499d
FC
2447 if (cloneall) {
2448 PADOFFSET depth;
9b7476d7 2449 for (depth = 1; depth <= max; ++depth)
86d2498c
FC
2450 PadlistARRAY(dstpad)[depth] =
2451 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
6de654a5
NC
2452 } else {
2453 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2454 to build anything other than the first level of pads. */
86d2498c 2455 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
6de654a5 2456 AV *pad1;
9b7476d7 2457 const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
86d2498c 2458 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
6de654a5 2459 SV **oldpad = AvARRAY(srcpad1);
3e020df5 2460 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
6de654a5
NC
2461 SV **pad1a;
2462 AV *args;
6de654a5 2463
6de654a5
NC
2464 pad1 = newAV();
2465
2466 av_extend(pad1, ix);
86d2498c 2467 PadlistARRAY(dstpad)[1] = pad1;
6de654a5 2468 pad1a = AvARRAY(pad1);
6de654a5
NC
2469
2470 if (ix > -1) {
2471 AvFILLp(pad1) = ix;
2472
2473 for ( ;ix > 0; ix--) {
05d04d9c
NC
2474 if (!oldpad[ix]) {
2475 pad1a[ix] = NULL;
ce0d59fd
FC
2476 } else if (names_fill >= ix && names[ix] &&
2477 PadnameLEN(names[ix])) {
3e020df5
FC
2478 const char sigil = PadnamePV(names[ix])[0];
2479 if (PadnameOUTER(names[ix])
2480 || PadnameIsSTATE(names[ix])
05d04d9c
NC
2481 || sigil == '&')
2482 {
2483 /* outer lexical or anon code */
2484 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2485 }
2486 else { /* our own lexical */
adf8f095
NC
2487 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2488 /* This is a work around for how the current
2489 implementation of ?{ } blocks in regexps
2490 interacts with lexicals. */
05d04d9c
NC
2491 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2492 } else {
2493 SV *sv;
2494
2495 if (sigil == '@')
2496 sv = MUTABLE_SV(newAV());
2497 else if (sigil == '%')
2498 sv = MUTABLE_SV(newHV());
2499 else
2500 sv = newSV(0);
2501 pad1a[ix] = sv;
05d04d9c
NC
2502 }
2503 }
2504 }
92154801 2505 else if (( names_fill >= ix && names[ix]
ce0d59fd 2506 && PadnamePV(names[ix]) )) {
05d04d9c
NC
2507 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2508 }
2509 else {
2510 /* save temporaries on recursion? */
2511 SV * const sv = newSV(0);
2512 pad1a[ix] = sv;
2513
2514 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2515 FIXTHAT before merging this branch.
2516 (And I know how to) */
145bf8ee 2517 if (SvPADTMP(oldpad[ix]))
05d04d9c
NC
2518 SvPADTMP_on(sv);
2519 }
6de654a5
NC
2520 }
2521
2522 if (oldpad[0]) {
2523 args = newAV(); /* Will be @_ */
2524 AvREIFY_only(args);
2525 pad1a[0] = (SV *)args;
2526 }
2527 }
2528 }
d5b1589c
NC
2529
2530 return dstpad;
2531}
2532
cc76b5cc 2533#endif /* USE_ITHREADS */
d5b1589c 2534
7261499d 2535PAD **
5aaab254 2536Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
7261499d 2537{
7261499d 2538 PAD **ary;
86d2498c 2539 SSize_t const oldmax = PadlistMAX(padlist);
7261499d
FC
2540
2541 PERL_ARGS_ASSERT_PADLIST_STORE;
2542
2543 assert(key >= 0);
2544
86d2498c
FC
2545 if (key > PadlistMAX(padlist)) {
2546 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2547 (SV ***)&PadlistARRAY(padlist),
2548 (SV ***)&PadlistARRAY(padlist));
2549 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
7261499d
FC
2550 PAD *);
2551 }
86d2498c 2552 ary = PadlistARRAY(padlist);
7261499d
FC
2553 SvREFCNT_dec(ary[key]);
2554 ary[key] = val;
2555 return &ary[key];
2556}
2557
66610fdd 2558/*
9b7476d7
FC
2559=for apidoc newPADNAMELIST
2560
2561Creates a new pad name list. C<max> is the highest index for which space
2562is allocated.
2563
2564=cut
2565*/
2566
2567PADNAMELIST *
2568Perl_newPADNAMELIST(pTHX_ size_t max)
2569{
2570 PADNAMELIST *pnl;
2571 Newx(pnl, 1, PADNAMELIST);
2572 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2573 PadnamelistMAX(pnl) = -1;
2574 PadnamelistREFCNT(pnl) = 1;
2575 PadnamelistMAXNAMED(pnl) = 0;
2576 pnl->xpadnl_max = max;
2577 return pnl;
2578}
2579
2580/*
2581=for apidoc padnamelist_store
2582
2583Stores the pad name (which may be null) at the given index, freeing any
2584existing pad name in that slot.
2585
2586=cut
2587*/
2588
2589PADNAME **
2590Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2591{
2592 PADNAME **ary;
2593
2594 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2595
2596 assert(key >= 0);
2597
2598 if (key > pnl->xpadnl_max)
2599 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2600 (SV ***)&PadnamelistARRAY(pnl),
2601 (SV ***)&PadnamelistARRAY(pnl));
2602 if (PadnamelistMAX(pnl) < key) {
2603 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2604 key-PadnamelistMAX(pnl), PADNAME *);
2605 PadnamelistMAX(pnl) = key;
2606 }
2607 ary = PadnamelistARRAY(pnl);
0f94cb1f
FC
2608 if (ary[key])
2609 PadnameREFCNT_dec(ary[key]);
9b7476d7
FC
2610 ary[key] = val;
2611 return &ary[key];
2612}
2613
2614/*
2615=for apidoc padnamelist_fetch
2616
2617Fetches the pad name from the given index.
2618
2619=cut
2620*/
2621
2622PADNAME *
2623Perl_padnamelist_fetch(pTHX_ PADNAMELIST *pnl, SSize_t key)
2624{
2625 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2626 ASSUME(key >= 0);
2627
2628 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2629}
2630
2631void
2632Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2633{
2634 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2635 if (!--PadnamelistREFCNT(pnl)) {
2636 while(PadnamelistMAX(pnl) >= 0)
0f94cb1f
FC
2637 {
2638 PADNAME * const pn =
2639 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2640 if (pn)
2641 PadnameREFCNT_dec(pn);
2642 }
9b7476d7
FC
2643 Safefree(PadnamelistARRAY(pnl));
2644 Safefree(pnl);
2645 }
2646}
2647
2648#if defined(USE_ITHREADS)
2649
2650/*
2651=for apidoc padnamelist_dup
2652
2653Duplicates a pad name list.
2654
2655=cut
2656*/
2657
2658PADNAMELIST *
2659Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2660{
2661 PADNAMELIST *dstpad;
2662 SSize_t max = PadnamelistMAX(srcpad);
2663
2664 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2665
2666 /* look for it in the table first */
2667 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2668 if (dstpad)
2669 return dstpad;
2670
2671 dstpad = newPADNAMELIST(max);
2672 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2673 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2674 PadnamelistMAX(dstpad) = max;
2675
2676 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2677 for (; max >= 0; max--)
0f94cb1f 2678 if (PadnamelistARRAY(srcpad)[max]) {
9b7476d7 2679 PadnamelistARRAY(dstpad)[max] =
0f94cb1f
FC
2680 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2681 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2682 }
9b7476d7
FC
2683
2684 return dstpad;
2685}
2686
2687#endif /* USE_ITHREADS */
2688
0f94cb1f
FC
2689/*
2690=for apidoc newPADNAMEpvn
2691
2692Constructs and returns a new pad name. I<s> must be a UTF8 string. Do not
2693use this for pad names that point to outer lexicals. See
2694L</newPADNAMEouter>.
2695
2696=cut
2697*/
2698
2699PADNAME *
2700Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len)
2701{
2702 struct padname_with_str *alloc;
2703 char *alloc2; /* for Newxz */
2704 PADNAME *pn;
2705 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2706 Newxz(alloc2,
2707 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2708 char);
2709 alloc = (struct padname_with_str *)alloc2;
2710 pn = (PADNAME *)alloc;
2711 PadnameREFCNT(pn) = 1;
2712 PadnamePV(pn) = alloc->xpadn_str;
2713 Copy(s, PadnamePV(pn), len, char);
2714 *(PadnamePV(pn) + len) = '\0';
2715 PadnameLEN(pn) = len;
2716 return pn;
2717}
2718
2719/*
2720=for apidoc newPADNAMEouter
2721
2722Constructs and returns a new pad name. Only use this function for names
2723that refer to outer lexicals. (See also L</newPADNAMEpvn>.) I<outer> is
2724the outer pad name that this one mirrors. The returned pad name has the
2725PADNAMEt_OUTER flag already set.
2726
2727=cut
2728*/
2729
2730PADNAME *
2731Perl_newPADNAMEouter(pTHX_ PADNAME *outer)
2732{
2733 PADNAME *pn;
2734 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2735 Newxz(pn, 1, PADNAME);
2736 PadnameREFCNT(pn) = 1;
2737 PadnamePV(pn) = PadnamePV(outer);
2738 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2739 another entry. The original pad name owns the buffer. */
2740 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2741 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2742 PadnameLEN(pn) = PadnameLEN(outer);
2743 return pn;
2744}
2745
2746void
2747Perl_padname_free(pTHX_ PADNAME *pn)
2748{
2749 PERL_ARGS_ASSERT_PADNAME_FREE;
2750 if (!--PadnameREFCNT(pn)) {
2751 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2752 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2753 return;
2754 }
2755 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2756 SvREFCNT_dec(PadnameOURSTASH(pn));
2757 if (PadnameOUTER(pn))
2758 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2759 Safefree(pn);
2760 }
2761}
2762
2763#if defined(USE_ITHREADS)
2764
2765/*
2766=for apidoc padname_dup
2767
2768Duplicates a pad name.
2769
2770=cut
2771*/
2772
2773PADNAME *
2774Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2775{
2776 PADNAME *dst;
2777
2778 PERL_ARGS_ASSERT_PADNAME_DUP;
2779
2780 /* look for it in the table first */
2781 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2782 if (dst)
2783 return dst;
2784
2785 if (!PadnamePV(src)) {
2786 dst = &PL_padname_undef;
2787 ptr_table_store(PL_ptr_table, src, dst);
2788 return dst;
2789 }
2790
2791 dst = PadnameOUTER(src)
2792 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2793 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2794 ptr_table_store(PL_ptr_table, src, dst);
2795 PadnameLEN(dst) = PadnameLEN(src);
2796 PadnameFLAGS(dst) = PadnameFLAGS(src);
2797 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2798 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2799 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2800 param);
2801 dst->xpadn_low = src->xpadn_low;
2802 dst->xpadn_high = src->xpadn_high;
2803 dst->xpadn_gen = src->xpadn_gen;
2804 return dst;
2805}
2806
2807#endif /* USE_ITHREADS */
9b7476d7
FC
2808
2809/*
66610fdd
RGS
2810 * Local variables:
2811 * c-indentation-style: bsd
2812 * c-basic-offset: 4
14d04a33 2813 * indent-tabs-mode: nil
66610fdd
RGS
2814 * End:
2815 *
14d04a33 2816 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2817 */