This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Note that certain flags are documented
[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
DM
21/*
22=head1 Pad Data Structures
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
NC
274/*
275=head1 Embedding Functions
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
9420b268
DM
1073because fake names in anon protoypes have to store in C<xpadn_low> the
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{
27da23d5 1633 dVAR;
dd2155a4 1634
f3548bdc 1635 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7 1636
db21619c
DM
1637 /* If this CV has had any 'eval-capable' ops planted in it:
1638 * i.e. it contains any of:
1639 *
1640 * * eval '...',
1641 * * //ee,
1642 * * use re 'eval'; /$var/
1643 * * /(?{..})/),
1644 *
1645 * Then any anon prototypes in the chain of CVs should be marked as
1646 * cloneable, so that for example the eval's CV in
1647 *
1648 * sub { eval '$x' }
1649 *
1650 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1651 * potentially have an eval executed within it.
b5c19bd7
DM
1652 */
1653
1654 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1655 const CV *cv;
b5c19bd7
DM
1656 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1657 if (cv != PL_compcv && CvCOMPILED(cv))
1658 break; /* no need to mark already-compiled code */
1659 if (CvANON(cv)) {
1660 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1661 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
b5c19bd7
DM
1662 CvCLONE_on(cv);
1663 }
00cc8743 1664 CvHASEVAL_on(cv);
b5c19bd7
DM
1665 }
1666 }
1667
eb8137a9 1668 /* extend namepad to match curpad */
9b7476d7
FC
1669 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1670 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1671
1672 if (type == padtidy_SUBCLONE) {
9b7476d7 1673 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1674 PADOFFSET ix;
b5c19bd7 1675
dd2155a4 1676 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
dbfcda05
FC
1677 PADNAME *namesv;
1678 if (!namep[ix]) namep[ix] = &PL_padname_undef;
dd2155a4 1679
dd2155a4
DM
1680 /*
1681 * The only things that a clonable function needs in its
3a6ce63a 1682 * pad are anonymous subs, constants and GVs.
dd2155a4
DM
1683 * The rest are created anew during cloning.
1684 */
b561f196 1685 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
3a6ce63a 1686 continue;
ce0d59fd
FC
1687 namesv = namep[ix];
1688 if (!(PadnamePV(namesv) &&
dbfcda05 1689 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
dd2155a4
DM
1690 {
1691 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1692 PL_curpad[ix] = NULL;
dd2155a4
DM
1693 }
1694 }
1695 }
1696 else if (type == padtidy_SUB) {
53c1dcc0 1697 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1698 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1699 AvREIFY_only(av);
dd2155a4
DM
1700 }
1701
4cee4ca8 1702 if (type == padtidy_SUB || type == padtidy_FORMAT) {
9b7476d7 1703 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1704 PADOFFSET ix;
dd2155a4 1705 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
0f94cb1f 1706 if (!namep[ix]) namep[ix] = &PL_padname_undef;
2347c8c0 1707 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
dd2155a4 1708 continue;
0f94cb1f 1709 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
adf8f095
NC
1710 /* This is a work around for how the current implementation of
1711 ?{ } blocks in regexps interacts with lexicals.
1712
1713 One of our lexicals.
1714 Can't do this on all lexicals, otherwise sub baz() won't
1715 compile in
1716
1717 my $foo;
1718
1719 sub bar { ++$foo; }
1720
1721 sub baz { ++$foo; }
1722
1723 because completion of compiling &bar calling pad_tidy()
1724 would cause (top level) $foo to be marked as stale, and
1725 "no longer available". */
1726 SvPADSTALE_on(PL_curpad[ix]);
1727 }
dd2155a4
DM
1728 }
1729 }
f3548bdc 1730 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1731}
1732
dd2155a4 1733/*
44170c9a 1734=for apidoc pad_free
dd2155a4 1735
8627550a 1736Free the SV at offset po in the current pad.
dd2155a4
DM
1737
1738=cut
1739*/
1740
dd2155a4
DM
1741void
1742Perl_pad_free(pTHX_ PADOFFSET po)
1743{
53de1311 1744#ifndef USE_PAD_RESET
ad9e6ae1 1745 SV *sv;
ff06c6b2 1746#endif
f3548bdc 1747 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1748 if (!PL_curpad)
1749 return;
1750 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1751 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1752 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1753 if (!po)
1754 Perl_croak(aTHX_ "panic: pad_free po");
1755
1756 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1757 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
dd2155a4
DM
1758 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1759 );
1760
53de1311 1761#ifndef USE_PAD_RESET
ad9e6ae1
DM
1762 sv = PL_curpad[po];
1763 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1764 SvFLAGS(sv) &= ~SVs_PADTMP;
1765
d12be05d 1766 if (po < PL_padix)
dd2155a4 1767 PL_padix = po - 1;
53d3c048 1768#endif
dd2155a4
DM
1769}
1770
dd2155a4 1771/*
44170c9a 1772=for apidoc do_dump_pad
dd2155a4
DM
1773
1774Dump the contents of a padlist
1775
1776=cut
1777*/
1778
1779void
1780Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1781{
9b7476d7 1782 const PADNAMELIST *pad_name;
e1ec3a88 1783 const AV *pad;
01326933 1784 PADNAME **pname;
dd2155a4 1785 SV **ppad;
d12be05d 1786 PADOFFSET ix;
dd2155a4 1787
7918f24d
NC
1788 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1789
dd2155a4
DM
1790 if (!padlist) {
1791 return;
1792 }
9b7476d7 1793 pad_name = PadlistNAMES(padlist);
86d2498c 1794 pad = PadlistARRAY(padlist)[1];
9b7476d7 1795 pname = PadnamelistARRAY(pad_name);
dd2155a4
DM
1796 ppad = AvARRAY(pad);
1797 Perl_dump_indent(aTHX_ level, file,
147e3846 1798 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
dd2155a4
DM
1799 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1800 );
1801
9b7476d7 1802 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
01326933 1803 const PADNAME *namesv = pname[ix];
325e1816 1804 if (namesv && !PadnameLEN(namesv)) {
a0714e2c 1805 namesv = NULL;
dd2155a4
DM
1806 }
1807 if (namesv) {
01326933 1808 if (PadnameOUTER(namesv))
ee6cee0c 1809 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1810 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1811 (int) ix,
1812 PTR2UV(ppad[ix]),
1813 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
01326933 1814 PadnamePV(namesv),
809abb02
NC
1815 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1816 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1817
ee6cee0c
DM
1818 );
1819 else
1820 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1821 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1822 (int) ix,
1823 PTR2UV(ppad[ix]),
1824 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1825 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1826 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
01326933 1827 PadnamePV(namesv)
ee6cee0c 1828 );
dd2155a4
DM
1829 }
1830 else if (full) {
1831 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1832 "%2d. 0x%" UVxf "<%lu>\n",
dd2155a4
DM
1833 (int) ix,
1834 PTR2UV(ppad[ix]),
1835 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1836 );
1837 }
1838 }
1839}
1840
cc76b5cc 1841#ifdef DEBUGGING
dd2155a4
DM
1842
1843/*
44170c9a 1844=for apidoc cv_dump
dd2155a4
DM
1845
1846dump the contents of a CV
1847
1848=cut
1849*/
1850
dd2155a4 1851STATIC void
e1ec3a88 1852S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1853{
53c1dcc0 1854 const CV * const outside = CvOUTSIDE(cv);
b70d5558 1855 PADLIST* const padlist = CvPADLIST(cv);
dd2155a4 1856
7918f24d
NC
1857 PERL_ARGS_ASSERT_CV_DUMP;
1858
dd2155a4 1859 PerlIO_printf(Perl_debug_log,
147e3846 1860 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
dd2155a4
DM
1861 title,
1862 PTR2UV(cv),
1863 (CvANON(cv) ? "ANON"
71f882da 1864 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1865 : (cv == PL_main_cv) ? "MAIN"
1866 : CvUNIQUE(cv) ? "UNIQUE"
1867 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1868 PTR2UV(outside),
1869 (!outside ? "null"
1870 : CvANON(outside) ? "ANON"
1871 : (outside == PL_main_cv) ? "MAIN"
1872 : CvUNIQUE(outside) ? "UNIQUE"
1873 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1874
1875 PerlIO_printf(Perl_debug_log,
147e3846 1876 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
dd2155a4
DM
1877 do_dump_pad(1, Perl_debug_log, padlist, 1);
1878}
dd2155a4 1879
cc76b5cc 1880#endif /* DEBUGGING */
dd2155a4
DM
1881
1882/*
44170c9a 1883=for apidoc cv_clone
dd2155a4 1884
2d7f6611 1885Clone a CV, making a lexical closure. C<proto> supplies the prototype
cc76b5cc
Z
1886of the function: its code, pad structure, and other attributes.
1887The prototype is combined with a capture of outer lexicals to which the
1888code refers, which are taken from the currently-executing instance of
1889the immediately surrounding code.
dd2155a4
DM
1890
1891=cut
1892*/
1893
e0c6a6b8 1894static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
e10681aa 1895
21195f4d 1896static CV *
e0c6a6b8
FC
1897S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1898 bool newcv)
dd2155a4 1899{
d12be05d 1900 PADOFFSET ix;
b70d5558 1901 PADLIST* const protopadlist = CvPADLIST(proto);
9b7476d7 1902 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
86d2498c 1903 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
39899bf0 1904 PADNAME** const pname = PadnamelistARRAY(protopad_name);
53c1dcc0 1905 SV** const ppad = AvARRAY(protopad);
d12be05d
DM
1906 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1907 const PADOFFSET fpad = AvFILLp(protopad);
b5c19bd7 1908 SV** outpad;
71f882da 1909 long depth;
e0c6a6b8
FC
1910 U32 subclones = 0;
1911 bool trouble = FALSE;
7918f24d 1912
dd2155a4
DM
1913 assert(!CvUNIQUE(proto));
1914
1b5aaca6
FC
1915 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1916 * reliable. The currently-running sub is always the one we need to
1917 * close over.
8d88fe29
FC
1918 * For my subs, the currently-running sub may not be the one we want.
1919 * We have to check whether it is a clone of CvOUTSIDE.
1b5aaca6
FC
1920 * Note that in general for formats, CvOUTSIDE != find_runcv.
1921 * Since formats may be nested inside closures, CvOUTSIDE may point
71f882da 1922 * to a prototype; we instead want the cloned parent who called us.
af41786f 1923 */
71f882da 1924
e07561e6 1925 if (!outside) {
ebfebee4 1926 if (CvWEAKOUTSIDE(proto))
71f882da 1927 outside = find_runcv(NULL);
e07561e6 1928 else {
af41786f 1929 outside = CvOUTSIDE(proto);
db4cf31d
FC
1930 if ((CvCLONE(outside) && ! CvCLONED(outside))
1931 || !CvPADLIST(outside)
b4db5868 1932 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
db4cf31d 1933 outside = find_runcv_where(
a56015b9 1934 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
70794f7b 1935 );
db4cf31d 1936 /* outside could be null */
5dff782d 1937 }
e07561e6 1938 }
5dff782d 1939 }
db4cf31d 1940 depth = outside ? CvDEPTH(outside) : 0;
71f882da
DM
1941 if (!depth)
1942 depth = 1;
b5c19bd7 1943
dd2155a4
DM
1944 ENTER;
1945 SAVESPTR(PL_compcv);
e07561e6 1946 PL_compcv = cv;
5fab0186 1947 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
dd2155a4 1948
a0d2bbd5
FC
1949 if (CvHASEVAL(cv))
1950 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
dd2155a4 1951
cbacc9aa 1952 SAVESPTR(PL_comppad_name);
9ef8d569 1953 PL_comppad_name = protopad_name;
eacbb379 1954 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
b4db5868 1955 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
dd2155a4 1956
b5c19bd7 1957 av_fill(PL_comppad, fpad);
dd2155a4 1958
dd2155a4
DM
1959 PL_curpad = AvARRAY(PL_comppad);
1960
db4cf31d 1961 outpad = outside && CvPADLIST(outside)
86d2498c 1962 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
f2ead8b8 1963 : NULL;
b4db5868 1964 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
b5c19bd7 1965
dd2155a4 1966 for (ix = fpad; ix > 0; ix--) {
39899bf0 1967 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
a0714e2c 1968 SV *sv = NULL;
325e1816 1969 if (namesv && PadnameLEN(namesv)) { /* lexical */
f2047bf1
FC
1970 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1971 NOOP;
1972 }
1973 else {
39899bf0 1974 if (PadnameOUTER(namesv)) { /* lexical from outside? */
5aec98df
FC
1975 /* formats may have an inactive, or even undefined, parent;
1976 but state vars are always available. */
f2ead8b8 1977 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
cae5dbbe 1978 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
db4cf31d 1979 && (!outside || !CvDEPTH(outside))) ) {
445f13ff 1980 S_unavailable(aTHX_ namesv);
a0714e2c 1981 sv = NULL;
71f882da 1982 }
33894c1a 1983 else
f84c484e 1984 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 1985 }
71f882da 1986 if (!sv) {
39899bf0 1987 const char sigil = PadnamePV(namesv)[0];
e1ec3a88 1988 if (sigil == '&')
e07561e6
FC
1989 /* If there are state subs, we need to clone them, too.
1990 But they may need to close over variables we have
1991 not cloned yet. So we will have to do a second
1992 pass. Furthermore, there may be state subs clos-
1993 ing over other state subs’ entries, so we have
1994 to put a stub here and then clone into it on the
1995 second pass. */
6d5c2147
FC
1996 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
1997 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
e0c6a6b8
FC
1998 subclones ++;
1999 if (CvOUTSIDE(ppad[ix]) != proto)
2000 trouble = TRUE;
6d5c2147 2001 sv = newSV_type(SVt_PVCV);
f3feca7a 2002 CvLEXICAL_on(sv);
6d5c2147
FC
2003 }
2004 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2005 {
2006 /* my sub */
81df9f6f 2007 /* Just provide a stub, but name it. It will be
7600a9e5 2008 upgraded to the real thing on scope entry. */
f7cf2d13 2009 dVAR;
e1588866 2010 U32 hash;
39899bf0
FC
2011 PERL_HASH(hash, PadnamePV(namesv)+1,
2012 PadnameLEN(namesv) - 1);
81df9f6f 2013 sv = newSV_type(SVt_PVCV);
cf748c3c
FC
2014 CvNAME_HEK_set(
2015 sv,
39899bf0
FC
2016 share_hek(PadnamePV(namesv)+1,
2017 1 - PadnameLEN(namesv),
e1588866 2018 hash)
cf748c3c 2019 );
f3feca7a 2020 CvLEXICAL_on(sv);
6d5c2147
FC
2021 }
2022 else sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 2023 else if (sigil == '@')
ad64d0ec 2024 sv = MUTABLE_SV(newAV());
e1ec3a88 2025 else if (sigil == '%')
ad64d0ec 2026 sv = MUTABLE_SV(newHV());
dd2155a4 2027 else
561b68a9 2028 sv = newSV(0);
0d3b281c 2029 /* reset the 'assign only once' flag on each state var */
e07561e6 2030 if (sigil != '&' && SvPAD_STATE(namesv))
0d3b281c 2031 SvPADSTALE_on(sv);
dd2155a4 2032 }
f2047bf1 2033 }
dd2155a4 2034 }
4c894bf7 2035 else if (namesv && PadnamePV(namesv)) {
f84c484e 2036 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
2037 }
2038 else {
561b68a9 2039 sv = newSV(0);
dd2155a4 2040 SvPADTMP_on(sv);
dd2155a4 2041 }
71f882da 2042 PL_curpad[ix] = sv;
dd2155a4
DM
2043 }
2044
e07561e6 2045 if (subclones)
e0c6a6b8
FC
2046 {
2047 if (trouble || cloned) {
2048 /* Uh-oh, we have trouble! At least one of the state subs here
2049 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2050 could be pointing to another state protosub that we are
2051 about to clone. So we have to track which sub clones come
2052 from which protosubs. If the CvOUTSIDE pointer for a parti-
2053 cular sub points to something we have not cloned yet, we
2054 delay cloning it. We must loop through the pad entries,
2055 until we get a full pass with no cloning. If any uncloned
2056 subs remain (probably nested inside anonymous or ‘my’ subs),
2057 then they get cloned in a final pass.
2058 */
2059 bool cloned_in_this_pass;
2060 if (!cloned)
2061 cloned = (HV *)sv_2mortal((SV *)newHV());
2062 do {
2063 cloned_in_this_pass = FALSE;
2064 for (ix = fpad; ix > 0; ix--) {
2065 PADNAME * const name =
2066 (ix <= fname) ? pname[ix] : NULL;
2067 if (name && name != &PL_padname_undef
2068 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2069 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2070 {
2071 CV * const protokey = CvOUTSIDE(ppad[ix]);
2072 CV ** const cvp = protokey == proto
2073 ? &cv
2074 : (CV **)hv_fetch(cloned, (char *)&protokey,
2075 sizeof(CV *), 0);
2076 if (cvp && *cvp) {
2077 S_cv_clone(aTHX_ (CV *)ppad[ix],
2078 (CV *)PL_curpad[ix],
2079 *cvp, cloned);
b53eee5d 2080 (void)hv_store(cloned, (char *)&ppad[ix],
e0c6a6b8
FC
2081 sizeof(CV *),
2082 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2083 0);
2084 subclones--;
2085 cloned_in_this_pass = TRUE;
2086 }
2087 }
2088 }
2089 } while (cloned_in_this_pass);
2090 if (subclones)
2091 for (ix = fpad; ix > 0; ix--) {
2092 PADNAME * const name =
2093 (ix <= fname) ? pname[ix] : NULL;
2094 if (name && name != &PL_padname_undef
2095 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2096 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2097 S_cv_clone(aTHX_ (CV *)ppad[ix],
2098 (CV *)PL_curpad[ix],
2099 CvOUTSIDE(ppad[ix]), cloned);
2100 }
2101 }
2102 else for (ix = fpad; ix > 0; ix--) {
39899bf0
FC
2103 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2104 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2105 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
e0c6a6b8
FC
2106 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2107 NULL);
e07561e6 2108 }
e0c6a6b8 2109 }
e07561e6 2110
5fab0186 2111 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
e10681aa 2112 LEAVE;
21195f4d 2113
1567c65a
FC
2114 if (CvCONST(cv)) {
2115 /* Constant sub () { $x } closing over $x:
2116 * The prototype was marked as a candiate for const-ization,
2117 * so try to grab the current const value, and if successful,
2118 * turn into a const sub:
2119 */
d8d6ddf8
FC
2120 SV* const_sv;
2121 OP *o = CvSTART(cv);
1567c65a 2122 assert(newcv);
d8d6ddf8
FC
2123 for (; o; o = o->op_next)
2124 if (o->op_type == OP_PADSV)
2125 break;
2126 ASSUME(o->op_type == OP_PADSV);
2127 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2128 /* the candidate should have 1 ref from this pad and 1 ref
2129 * from the parent */
2130 if (const_sv && SvREFCNT(const_sv) == 2) {
1567c65a 2131 const bool was_method = cBOOL(CvMETHOD(cv));
d8d6ddf8
FC
2132 if (outside) {
2133 PADNAME * const pn =
2134 PadlistNAMESARRAY(CvPADLIST(outside))
2135 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2136 CvPADLIST(cv))[o->op_targ])];
2137 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2138 [o->op_targ]));
2139 if (PadnameLVALUE(pn)) {
2140 /* We have a lexical that is potentially modifiable
2141 elsewhere, so making a constant will break clo-
2142 sure behaviour. If this is a ‘simple lexical
2143 op tree’, i.e., sub(){$x}, emit a deprecation
2144 warning, but continue to exhibit the old behav-
2145 iour of making it a constant based on the ref-
2146 count of the candidate variable.
2147
2148 A simple lexical op tree looks like this:
2149
2150 leavesub
2151 lineseq
2152 nextstate
2153 padsv
2154 */
e6dae479 2155 if (OpSIBLING(
d8d6ddf8
FC
2156 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2157 ) == o
e6dae479 2158 && !OpSIBLING(o))
04472a84 2159 {
30fc7a28
JK
2160 Perl_croak(aTHX_
2161 "Constants from lexical variables potentially modified "
2162 "elsewhere are no longer permitted");
04472a84 2163 }
d8d6ddf8
FC
2164 else
2165 goto constoff;
2166 }
2167 }
30fc7a28 2168 SvREFCNT_inc_simple_void_NN(const_sv);
04472a84
FC
2169 /* If the lexical is not used elsewhere, it is safe to turn on
2170 SvPADTMP, since it is only when it is used in lvalue con-
2171 text that the difference is observable. */
6dfba0aa 2172 SvREADONLY_on(const_sv);
d8d6ddf8 2173 SvPADTMP_on(const_sv);
1567c65a 2174 SvREFCNT_dec_NN(cv);
1567c65a
FC
2175 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2176 if (was_method)
2177 CvMETHOD_on(cv);
2178 }
2179 else {
d8d6ddf8 2180 constoff:
1567c65a
FC
2181 CvCONST_off(cv);
2182 }
2183 }
2184
21195f4d 2185 return cv;
e10681aa
FC
2186}
2187
2188static CV *
e0c6a6b8 2189S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
e10681aa 2190{
20b7effb 2191#ifdef USE_ITHREADS
c04ef36e 2192 dVAR;
20b7effb 2193#endif
5fab0186 2194 const bool newcv = !cv;
c04ef36e 2195
e10681aa
FC
2196 assert(!CvUNIQUE(proto));
2197
2198 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2199 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2200 |CVf_SLABBED);
2201 CvCLONED_on(cv);
2202
2203 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2204 : CvFILE(proto);
2205 if (CvNAMED(proto))
2e800d79 2206 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
e10681aa
FC
2207 else CvGV_set(cv,CvGV(proto));
2208 CvSTASH_set(cv, CvSTASH(proto));
2209 OP_REFCNT_LOCK;
2210 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2211 OP_REFCNT_UNLOCK;
2212 CvSTART(cv) = CvSTART(proto);
2213 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2214
fdf416b6 2215 if (SvPOK(proto)) {
e10681aa 2216 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
fdf416b6
BF
2217 if (SvUTF8(proto))
2218 SvUTF8_on(MUTABLE_SV(cv));
2219 }
e10681aa
FC
2220 if (SvMAGIC(proto))
2221 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2222
21195f4d 2223 if (CvPADLIST(proto))
e0c6a6b8 2224 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
e10681aa 2225
dd2155a4
DM
2226 DEBUG_Xv(
2227 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
e10681aa 2228 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
dd2155a4
DM
2229 cv_dump(proto, "Proto");
2230 cv_dump(cv, "To");
2231 );
2232
dd2155a4
DM
2233 return cv;
2234}
2235
e07561e6
FC
2236CV *
2237Perl_cv_clone(pTHX_ CV *proto)
2238{
2239 PERL_ARGS_ASSERT_CV_CLONE;
2240
fead5351 2241 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
e0c6a6b8 2242 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
e07561e6
FC
2243}
2244
6d5c2147
FC
2245/* Called only by pp_clonecv */
2246CV *
2247Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2248{
2249 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2250 cv_undef(target);
e0c6a6b8 2251 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
6d5c2147
FC
2252}
2253
fb094047
FC
2254/*
2255=for apidoc cv_name
2256
2257Returns an SV containing the name of the CV, mainly for use in error
2258reporting. The CV may actually be a GV instead, in which case the returned
7a275a2e
FC
2259SV holds the GV's name. Anything other than a GV or CV is treated as a
2260string already holding the sub name, but this could change in the future.
fb094047
FC
2261
2262An SV may be passed as a second argument. If so, the name will be assigned
2263to it and it will be returned. Otherwise the returned SV will be a new
2264mortal.
2265
c5608a1f 2266If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
ecf05a58
FC
2267included. If the first argument is neither a CV nor a GV, this flag is
2268ignored (subject to change).
2269
5af38e47
KW
2270=for apidoc Amnh||CV_NAME_NOTQUAL
2271
fb094047
FC
2272=cut
2273*/
2274
c5569a55 2275SV *
ecf05a58 2276Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
c5569a55
FC
2277{
2278 PERL_ARGS_ASSERT_CV_NAME;
2279 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2280 if (sv) sv_setsv(sv,(SV *)cv);
2281 return sv ? (sv) : (SV *)cv;
2282 }
2283 {
f3fb6cf3 2284 SV * const retsv = sv ? (sv) : sv_newmortal();
c5569a55
FC
2285 if (SvTYPE(cv) == SVt_PVCV) {
2286 if (CvNAMED(cv)) {
ecf05a58
FC
2287 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2288 sv_sethek(retsv, CvNAME_HEK(cv));
c5569a55 2289 else {
6881372e
FC
2290 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2291 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2292 else
2293 sv_setpvs(retsv, "__ANON__");
c5569a55 2294 sv_catpvs(retsv, "::");
f34d8cdd 2295 sv_cathek(retsv, CvNAME_HEK(cv));
c5569a55
FC
2296 }
2297 }
ecf05a58 2298 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
c5569a55
FC
2299 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2300 else gv_efullname3(retsv, CvGV(cv), NULL);
2301 }
ecf05a58 2302 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
c5569a55
FC
2303 else gv_efullname3(retsv,(GV *)cv,NULL);
2304 return retsv;
2305 }
2306}
2307
dd2155a4 2308/*
44170c9a 2309=for apidoc pad_fixup_inner_anons
dd2155a4 2310
796b6530
KW
2311For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2312C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
7dafbf52 2313moved to a pre-existing CV struct.
dd2155a4
DM
2314
2315=cut
2316*/
2317
2318void
2319Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2320{
d12be05d 2321 PADOFFSET ix;
9b7476d7 2322 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
86d2498c 2323 AV * const comppad = PadlistARRAY(padlist)[1];
0f94cb1f 2324 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
53c1dcc0 2325 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
2326
2327 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
2328 PERL_UNUSED_ARG(old_cv);
2329
9b7476d7 2330 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
307cbb9f
FC
2331 const PADNAME *name = namepad[ix];
2332 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
0f94cb1f 2333 && *PadnamePV(name) == '&')
dd2155a4 2334 {
307cbb9f
FC
2335 CV *innercv = MUTABLE_CV(curpad[ix]);
2336 if (UNLIKELY(PadnameOUTER(name))) {
2337 CV *cv = new_cv;
2338 PADNAME **names = namepad;
2339 PADOFFSET i = ix;
2340 while (PadnameOUTER(name)) {
95c0a761 2341 assert(SvTYPE(cv) == SVt_PVCV);
307cbb9f
FC
2342 cv = CvOUTSIDE(cv);
2343 names = PadlistNAMESARRAY(CvPADLIST(cv));
2344 i = PARENT_PAD_INDEX(name);
2345 name = names[i];
2346 }
2347 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2348 }
2349 if (SvTYPE(innercv) == SVt_PVCV) {
0f94cb1f
FC
2350 /* XXX 0afba48f added code here to check for a proto CV
2351 attached to the pad entry by magic. But shortly there-
2352 after 81df9f6f95 moved the magic to the pad name. The
2353 code here was never updated, so it wasn’t doing anything
2354 and got deleted when PADNAME became a distinct type. Is
2355 there any bug as a result? */
0afba48f 2356 if (CvOUTSIDE(innercv) == old_cv) {
1f122f9b
FC
2357 if (!CvWEAKOUTSIDE(innercv)) {
2358 SvREFCNT_dec(old_cv);
2359 SvREFCNT_inc_simple_void_NN(new_cv);
2360 }
0afba48f
FC
2361 CvOUTSIDE(innercv) = new_cv;
2362 }
e09ac076
FC
2363 }
2364 else { /* format reference */
2365 SV * const rv = curpad[ix];
2366 CV *innercv;
2367 if (!SvOK(rv)) continue;
2368 assert(SvROK(rv));
2369 assert(SvWEAKREF(rv));
2370 innercv = (CV *)SvRV(rv);
2371 assert(!CvWEAKOUTSIDE(innercv));
95c0a761 2372 assert(CvOUTSIDE(innercv) == old_cv);
e09ac076
FC
2373 SvREFCNT_dec(CvOUTSIDE(innercv));
2374 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2375 }
dd2155a4
DM
2376 }
2377 }
2378}
2379
2380/*
44170c9a 2381=for apidoc pad_push
dd2155a4
DM
2382
2383Push a new pad frame onto the padlist, unless there's already a pad at
26019298 2384this depth, in which case don't bother creating a new one. Then give
796b6530 2385the new pad an C<@_> in slot zero.
dd2155a4
DM
2386
2387=cut
2388*/
2389
2390void
26019298 2391Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2392{
7918f24d
NC
2393 PERL_ARGS_ASSERT_PAD_PUSH;
2394
86d2498c
FC
2395 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2396 PAD** const svp = PadlistARRAY(padlist);
44f8325f
AL
2397 AV* const newpad = newAV();
2398 SV** const oldpad = AvARRAY(svp[depth-1]);
d12be05d
DM
2399 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2400 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
a2ddd1d1 2401 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
26019298
AL
2402 AV *av;
2403
dd2155a4 2404 for ( ;ix > 0; ix--) {
325e1816 2405 if (names_fill >= ix && PadnameLEN(names[ix])) {
a2ddd1d1
FC
2406 const char sigil = PadnamePV(names[ix])[0];
2407 if (PadnameOUTER(names[ix])
2408 || PadnameIsSTATE(names[ix])
fda94784
RGS
2409 || sigil == '&')
2410 {
dd2155a4
DM
2411 /* outer lexical or anon code */
2412 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2413 }
2414 else { /* our own lexical */
26019298
AL
2415 SV *sv;
2416 if (sigil == '@')
ad64d0ec 2417 sv = MUTABLE_SV(newAV());
26019298 2418 else if (sigil == '%')
ad64d0ec 2419 sv = MUTABLE_SV(newHV());
dd2155a4 2420 else
561b68a9 2421 sv = newSV(0);
26019298 2422 av_store(newpad, ix, sv);
dd2155a4
DM
2423 }
2424 }
778f1807 2425 else if (PadnamePV(names[ix])) {
f84c484e 2426 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2427 }
2428 else {
2429 /* save temporaries on recursion? */
561b68a9 2430 SV * const sv = newSV(0);
26019298 2431 av_store(newpad, ix, sv);
dd2155a4
DM
2432 SvPADTMP_on(sv);
2433 }
2434 }
26019298 2435 av = newAV();
ad64d0ec 2436 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2437 AvREIFY_only(av);
26019298 2438
7261499d 2439 padlist_store(padlist, depth, newpad);
dd2155a4
DM
2440 }
2441}
b21dc031 2442
d5b1589c
NC
2443#if defined(USE_ITHREADS)
2444
2445# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2446
cc76b5cc 2447/*
b70d5558 2448=for apidoc padlist_dup
cc76b5cc
Z
2449
2450Duplicates a pad.
2451
2452=cut
2453*/
2454
b70d5558
FC
2455PADLIST *
2456Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
d5b1589c 2457{
7261499d
FC
2458 PADLIST *dstpad;
2459 bool cloneall;
2460 PADOFFSET max;
2461
d5b1589c
NC
2462 PERL_ARGS_ASSERT_PADLIST_DUP;
2463
71c165d4 2464 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
86d2498c 2465 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
7261499d 2466
86d2498c 2467 max = cloneall ? PadlistMAX(srcpad) : 1;
7261499d
FC
2468
2469 Newx(dstpad, 1, PADLIST);
2470 ptr_table_store(PL_ptr_table, srcpad, dstpad);
86d2498c
FC
2471 PadlistMAX(dstpad) = max;
2472 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
7261499d 2473
9b7476d7
FC
2474 PadlistARRAY(dstpad)[0] = (PAD *)
2475 padnamelist_dup(PadlistNAMES(srcpad), param);
2476 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
7261499d
FC
2477 if (cloneall) {
2478 PADOFFSET depth;
9b7476d7 2479 for (depth = 1; depth <= max; ++depth)
86d2498c
FC
2480 PadlistARRAY(dstpad)[depth] =
2481 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
6de654a5
NC
2482 } else {
2483 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2484 to build anything other than the first level of pads. */
d12be05d 2485 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
6de654a5 2486 AV *pad1;
d12be05d 2487 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
86d2498c 2488 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
6de654a5 2489 SV **oldpad = AvARRAY(srcpad1);
3e020df5 2490 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
6de654a5
NC
2491 SV **pad1a;
2492 AV *args;
6de654a5 2493
6de654a5
NC
2494 pad1 = newAV();
2495
2496 av_extend(pad1, ix);
86d2498c 2497 PadlistARRAY(dstpad)[1] = pad1;
6de654a5 2498 pad1a = AvARRAY(pad1);
6de654a5
NC
2499
2500 if (ix > -1) {
2501 AvFILLp(pad1) = ix;
2502
2503 for ( ;ix > 0; ix--) {
05d04d9c
NC
2504 if (!oldpad[ix]) {
2505 pad1a[ix] = NULL;
ce0d59fd
FC
2506 } else if (names_fill >= ix && names[ix] &&
2507 PadnameLEN(names[ix])) {
3e020df5
FC
2508 const char sigil = PadnamePV(names[ix])[0];
2509 if (PadnameOUTER(names[ix])
2510 || PadnameIsSTATE(names[ix])
05d04d9c
NC
2511 || sigil == '&')
2512 {
2513 /* outer lexical or anon code */
2514 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2515 }
2516 else { /* our own lexical */
adf8f095
NC
2517 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2518 /* This is a work around for how the current
2519 implementation of ?{ } blocks in regexps
2520 interacts with lexicals. */
05d04d9c
NC
2521 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2522 } else {
2523 SV *sv;
2524
2525 if (sigil == '@')
2526 sv = MUTABLE_SV(newAV());
2527 else if (sigil == '%')
2528 sv = MUTABLE_SV(newHV());
2529 else
2530 sv = newSV(0);
2531 pad1a[ix] = sv;
05d04d9c
NC
2532 }
2533 }
2534 }
92154801 2535 else if (( names_fill >= ix && names[ix]
ce0d59fd 2536 && PadnamePV(names[ix]) )) {
05d04d9c
NC
2537 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2538 }
2539 else {
2540 /* save temporaries on recursion? */
2541 SV * const sv = newSV(0);
2542 pad1a[ix] = sv;
2543
2544 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2545 FIXTHAT before merging this branch.
2546 (And I know how to) */
145bf8ee 2547 if (SvPADTMP(oldpad[ix]))
05d04d9c
NC
2548 SvPADTMP_on(sv);
2549 }
6de654a5
NC
2550 }
2551
2552 if (oldpad[0]) {
2553 args = newAV(); /* Will be @_ */
2554 AvREIFY_only(args);
2555 pad1a[0] = (SV *)args;
2556 }
2557 }
2558 }
d5b1589c
NC
2559
2560 return dstpad;
2561}
2562
cc76b5cc 2563#endif /* USE_ITHREADS */
d5b1589c 2564
7261499d 2565PAD **
5aaab254 2566Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
7261499d 2567{
7261499d 2568 PAD **ary;
86d2498c 2569 SSize_t const oldmax = PadlistMAX(padlist);
7261499d
FC
2570
2571 PERL_ARGS_ASSERT_PADLIST_STORE;
2572
2573 assert(key >= 0);
2574
86d2498c
FC
2575 if (key > PadlistMAX(padlist)) {
2576 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2577 (SV ***)&PadlistARRAY(padlist),
2578 (SV ***)&PadlistARRAY(padlist));
2579 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
7261499d
FC
2580 PAD *);
2581 }
86d2498c 2582 ary = PadlistARRAY(padlist);
7261499d
FC
2583 SvREFCNT_dec(ary[key]);
2584 ary[key] = val;
2585 return &ary[key];
2586}
2587
66610fdd 2588/*
9b7476d7
FC
2589=for apidoc newPADNAMELIST
2590
2591Creates a new pad name list. C<max> is the highest index for which space
2592is allocated.
2593
2594=cut
2595*/
2596
2597PADNAMELIST *
a0e9f837 2598Perl_newPADNAMELIST(size_t max)
9b7476d7
FC
2599{
2600 PADNAMELIST *pnl;
2601 Newx(pnl, 1, PADNAMELIST);
2602 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2603 PadnamelistMAX(pnl) = -1;
2604 PadnamelistREFCNT(pnl) = 1;
2605 PadnamelistMAXNAMED(pnl) = 0;
2606 pnl->xpadnl_max = max;
2607 return pnl;
2608}
2609
2610/*
2611=for apidoc padnamelist_store
2612
2613Stores the pad name (which may be null) at the given index, freeing any
2614existing pad name in that slot.
2615
2616=cut
2617*/
2618
2619PADNAME **
2620Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2621{
2622 PADNAME **ary;
2623
2624 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2625
2626 assert(key >= 0);
2627
2628 if (key > pnl->xpadnl_max)
2629 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2630 (SV ***)&PadnamelistARRAY(pnl),
2631 (SV ***)&PadnamelistARRAY(pnl));
2632 if (PadnamelistMAX(pnl) < key) {
2633 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2634 key-PadnamelistMAX(pnl), PADNAME *);
2635 PadnamelistMAX(pnl) = key;
2636 }
2637 ary = PadnamelistARRAY(pnl);
0f94cb1f
FC
2638 if (ary[key])
2639 PadnameREFCNT_dec(ary[key]);
9b7476d7
FC
2640 ary[key] = val;
2641 return &ary[key];
2642}
2643
2644/*
2645=for apidoc padnamelist_fetch
2646
2647Fetches the pad name from the given index.
2648
2649=cut
2650*/
2651
2652PADNAME *
a0e9f837 2653Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
9b7476d7
FC
2654{
2655 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2656 ASSUME(key >= 0);
2657
2658 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2659}
2660
2661void
2662Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2663{
2664 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2665 if (!--PadnamelistREFCNT(pnl)) {
2666 while(PadnamelistMAX(pnl) >= 0)
0f94cb1f
FC
2667 {
2668 PADNAME * const pn =
2669 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2670 if (pn)
2671 PadnameREFCNT_dec(pn);
2672 }
9b7476d7
FC
2673 Safefree(PadnamelistARRAY(pnl));
2674 Safefree(pnl);
2675 }
2676}
2677
2678#if defined(USE_ITHREADS)
2679
2680/*
2681=for apidoc padnamelist_dup
2682
2683Duplicates a pad name list.
2684
2685=cut
2686*/
2687
2688PADNAMELIST *
2689Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2690{
2691 PADNAMELIST *dstpad;
2692 SSize_t max = PadnamelistMAX(srcpad);
2693
2694 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2695
2696 /* look for it in the table first */
2697 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2698 if (dstpad)
2699 return dstpad;
2700
2701 dstpad = newPADNAMELIST(max);
2702 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2703 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2704 PadnamelistMAX(dstpad) = max;
2705
2706 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2707 for (; max >= 0; max--)
0f94cb1f 2708 if (PadnamelistARRAY(srcpad)[max]) {
9b7476d7 2709 PadnamelistARRAY(dstpad)[max] =
0f94cb1f
FC
2710 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2711 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2712 }
9b7476d7
FC
2713
2714 return dstpad;
2715}
2716
2717#endif /* USE_ITHREADS */
2718
0f94cb1f
FC
2719/*
2720=for apidoc newPADNAMEpvn
2721
4a4088c4 2722Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
0f94cb1f 2723use this for pad names that point to outer lexicals. See
fbe13c60 2724C<L</newPADNAMEouter>>.
0f94cb1f
FC
2725
2726=cut
2727*/
2728
2729PADNAME *
a0e9f837 2730Perl_newPADNAMEpvn(const char *s, STRLEN len)
0f94cb1f
FC
2731{
2732 struct padname_with_str *alloc;
2733 char *alloc2; /* for Newxz */
2734 PADNAME *pn;
2735 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2736 Newxz(alloc2,
2737 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2738 char);
2739 alloc = (struct padname_with_str *)alloc2;
2740 pn = (PADNAME *)alloc;
2741 PadnameREFCNT(pn) = 1;
2742 PadnamePV(pn) = alloc->xpadn_str;
2743 Copy(s, PadnamePV(pn), len, char);
2744 *(PadnamePV(pn) + len) = '\0';
2745 PadnameLEN(pn) = len;
2746 return pn;
2747}
2748
2749/*
2750=for apidoc newPADNAMEouter
2751
2752Constructs and returns a new pad name. Only use this function for names
2d7f6611 2753that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
0f94cb1f 2754the outer pad name that this one mirrors. The returned pad name has the
796b6530 2755C<PADNAMEt_OUTER> flag already set.
0f94cb1f 2756
5af38e47
KW
2757=for apidoc Amnh||PADNAMEt_OUTER
2758
0f94cb1f
FC
2759=cut
2760*/
2761
2762PADNAME *
a0e9f837 2763Perl_newPADNAMEouter(PADNAME *outer)
0f94cb1f
FC
2764{
2765 PADNAME *pn;
2766 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2767 Newxz(pn, 1, PADNAME);
2768 PadnameREFCNT(pn) = 1;
2769 PadnamePV(pn) = PadnamePV(outer);
2770 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2771 another entry. The original pad name owns the buffer. */
2772 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2773 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2774 PadnameLEN(pn) = PadnameLEN(outer);
2775 return pn;
2776}
2777
2778void
2779Perl_padname_free(pTHX_ PADNAME *pn)
2780{
2781 PERL_ARGS_ASSERT_PADNAME_FREE;
2782 if (!--PadnameREFCNT(pn)) {
2783 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2784 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2785 return;
2786 }
2787 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2788 SvREFCNT_dec(PadnameOURSTASH(pn));
2789 if (PadnameOUTER(pn))
2790 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2791 Safefree(pn);
2792 }
2793}
2794
2795#if defined(USE_ITHREADS)
2796
2797/*
2798=for apidoc padname_dup
2799
2800Duplicates a pad name.
2801
2802=cut
2803*/
2804
2805PADNAME *
2806Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2807{
2808 PADNAME *dst;
2809
2810 PERL_ARGS_ASSERT_PADNAME_DUP;
2811
2812 /* look for it in the table first */
2813 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2814 if (dst)
2815 return dst;
2816
2817 if (!PadnamePV(src)) {
2818 dst = &PL_padname_undef;
2819 ptr_table_store(PL_ptr_table, src, dst);
2820 return dst;
2821 }
2822
2823 dst = PadnameOUTER(src)
2824 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2825 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2826 ptr_table_store(PL_ptr_table, src, dst);
2827 PadnameLEN(dst) = PadnameLEN(src);
2828 PadnameFLAGS(dst) = PadnameFLAGS(src);
2829 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2830 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2831 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2832 param);
2833 dst->xpadn_low = src->xpadn_low;
2834 dst->xpadn_high = src->xpadn_high;
2835 dst->xpadn_gen = src->xpadn_gen;
2836 return dst;
2837}
2838
2839#endif /* USE_ITHREADS */
9b7476d7
FC
2840
2841/*
14d04a33 2842 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2843 */