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