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