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