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