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