This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make pad_fixup_inner_anons cope with closed-over subs
[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
DM
40
41XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42but that is really the callers pad (a slot of which is allocated by
43every entersub).
44
58a9b2fe 45The PADLIST has a C array where pads are stored.
dd2155a4 46
58a9b2fe
FC
47The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48AV, but that may change) which represents the "names" or rather
49the "static type information" for lexicals. The individual elements of a
7a5eb04d
FC
50PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
51refactorings might stop the PADNAMELIST from being stored in the PADLIST's
86d2498c 52array, so don't rely on it. See L</PadlistNAMES>.
dd2155a4 53
58a9b2fe
FC
54The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55at that depth of recursion into the CV. The 0th slot of a frame AV is an
56AV which is @_. Other entries are storage for variables and op targets.
dd2155a4 57
58a9b2fe
FC
58Iterating over the PADNAMELIST iterates over all possible pad
59items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
dd2155a4
DM
60&PL_sv_undef "names" (see pad_alloc()).
61
58a9b2fe 62Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
dd2155a4
DM
63The rest are op targets/GVs/constants which are statically allocated
64or resolved at compile time. These don't have names by which they
58a9b2fe 65can be looked up from Perl code at run time through eval"" the way
dd2155a4
DM
66my/our variables can be. Since they can't be looked up by "name"
67but only by their index allocated at compile time (which is usually
68in PL_op->op_targ), wasting a name SV for them doesn't make sense.
69
70The SVs in the names AV have their PV being the name of the variable.
3441fb63 71xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
61f4bfbf
DM
72which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73_HIGH). During compilation, these fields may hold the special value
74PERL_PADSEQ_INTRO to indicate various stages:
0d311cdb
DM
75
76 COP_SEQ_RANGE_LOW _HIGH
77 ----------------- -----
78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
80 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
81
82For typed lexicals name SV is SVt_PVMG and SvSTASH
3441fb63 83points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
73d95100 84SvOURSTASH slot pointing at the stash of the associated global (so that
931b58fb 85duplicate C<our> declarations in the same package can be detected). SvUVX is
3441fb63 86sometimes hijacked to store the generation number during compilation.
dd2155a4 87
c44737a2
FC
88If PADNAME_OUTER (SvFAKE) is set on the
89name SV, then that slot in the frame AV is
b5c19bd7 90a REFCNT'ed reference to a lexical from "outside". In this case,
3441fb63
NC
91the name SV does not use xlow and xhigh to store a cop_seq range, since it is
92in scope throughout. Instead xhigh stores some flags containing info about
b5c19bd7 93the real lexical (is it declared in an anon, and is it capable of being
3441fb63 94instantiated multiple times?), and for fake ANONs, xlow contains the index
b5c19bd7
DM
95within the parent's pad where the lexical's value is stored, to make
96cloning quicker.
dd2155a4 97
58a9b2fe 98If the 'name' is '&' the corresponding entry in the PAD
dd2155a4 99is a CV representing a possible closure.
c44737a2
FC
100(PADNAME_OUTER and name of '&' is not a
101meaningful combination currently but could
dd2155a4
DM
102become so if C<my sub foo {}> is implemented.)
103
71f882da
DM
104Note that formats are treated as anon subs, and are cloned each time
105write is called (if necessary).
106
ab8e66c1 107The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
58a9b2fe
FC
108and set on scope exit. This allows the
109'Variable $x is not available' warning
e6e7068b
DM
110to be generated in evals, such as
111
112 { my $x = 1; sub f { eval '$x'} } f();
113
58a9b2fe 114For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
d1186544 115
36c300bb 116=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
cc76b5cc
Z
117
118During compilation, this points to the array containing the names part
119of the pad for the currently-compiling code.
120
36c300bb 121=for apidoc AmxU|PAD *|PL_comppad
cc76b5cc
Z
122
123During compilation, this points to the array containing the values
124part of the pad for the currently-compiling code. (At runtime a CV may
125have many such value arrays; at compile time just one is constructed.)
126At runtime, this points to the array containing the currently-relevant
127values for the pad for the currently-executing code.
128
129=for apidoc AmxU|SV **|PL_curpad
130
131Points directly to the body of the L</PL_comppad> array.
c14a2249 132(I.e., this is C<PAD_ARRAY(PL_comppad)>.)
cc76b5cc 133
dd2155a4
DM
134=cut
135*/
136
137
138#include "EXTERN.h"
139#define PERL_IN_PAD_C
140#include "perl.h"
952306ac 141#include "keywords.h"
dd2155a4 142
3441fb63
NC
143#define COP_SEQ_RANGE_LOW_set(sv,val) \
144 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
145#define COP_SEQ_RANGE_HIGH_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
809abb02 147
3441fb63
NC
148#define PARENT_PAD_INDEX_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150#define PARENT_FAKELEX_FLAGS_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
dd2155a4 152
cc76b5cc
Z
153/*
154=for apidoc mx|void|pad_peg|const char *s
155
156When PERL_MAD is enabled, this is a small no-op function that gets called
157at the start of each pad-related function. It can be breakpointed to
158track all pad operations. The parameter is a string indicating the type
159of pad operation being performed.
160
161=cut
162*/
163
1dba731d
NC
164#ifdef PERL_MAD
165void pad_peg(const char* s) {
790427a5
DM
166 static int pegcnt; /* XXX not threadsafe */
167 PERL_UNUSED_ARG(s);
7918f24d
NC
168
169 PERL_ARGS_ASSERT_PAD_PEG;
170
1dba731d
NC
171 pegcnt++;
172}
173#endif
dd2155a4
DM
174
175/*
5b16296c
BF
176This is basically sv_eq_flags() in sv.c, but we avoid the magic
177and bytes checking.
178*/
179
76d60a53
NC
180static bool
181sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
5b16296c
BF
182 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
183 const char *pv1 = SvPVX_const(sv);
184 STRLEN cur1 = SvCUR(sv);
185 const char *pv2 = pv;
186 STRLEN cur2 = pvlen;
187 if (PL_encoding) {
188 SV* svrecode = NULL;
189 if (SvUTF8(sv)) {
190 svrecode = newSVpvn(pv2, cur2);
191 sv_recode_to_utf8(svrecode, PL_encoding);
192 pv2 = SvPV_const(svrecode, cur2);
193 }
194 else {
195 svrecode = newSVpvn(pv1, cur1);
196 sv_recode_to_utf8(svrecode, PL_encoding);
197 pv1 = SvPV_const(svrecode, cur1);
198 }
199 SvREFCNT_dec(svrecode);
200 }
201 if (flags & SVf_UTF8)
202 return (bytes_cmp_utf8(
203 (const U8*)pv1, cur1,
204 (const U8*)pv2, cur2) == 0);
205 else
206 return (bytes_cmp_utf8(
207 (const U8*)pv2, cur2,
208 (const U8*)pv1, cur1) == 0);
209 }
210 else
211 return ((SvPVX_const(sv) == pv)
212 || memEQ(SvPVX_const(sv), pv, pvlen));
213}
214
215
216/*
cc76b5cc 217=for apidoc Am|PADLIST *|pad_new|int flags
dd2155a4 218
cc76b5cc
Z
219Create a new padlist, updating the global variables for the
220currently-compiling padlist to point to the new padlist. The following
221flags can be OR'ed together:
dd2155a4
DM
222
223 padnew_CLONE this pad is for a cloned CV
cc76b5cc 224 padnew_SAVE save old globals on the save stack
dd2155a4
DM
225 padnew_SAVESUB also save extra stuff for start of sub
226
227=cut
228*/
229
230PADLIST *
c7c737cb 231Perl_pad_new(pTHX_ int flags)
dd2155a4 232{
97aff369 233 dVAR;
7261499d
FC
234 PADLIST *padlist;
235 PAD *padname, *pad;
236 PAD **ary;
dd2155a4 237
f3548bdc
DM
238 ASSERT_CURPAD_LEGAL("pad_new");
239
dd2155a4
DM
240 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
241 * vars (based on flags) rather than storing vals + addresses for
242 * each individually. Also see pad_block_start.
243 * XXX DAPM Try to see whether all these conditionals are required
244 */
245
246 /* save existing state, ... */
247
248 if (flags & padnew_SAVE) {
3979c56f 249 SAVECOMPPAD();
dd2155a4 250 if (! (flags & padnew_CLONE)) {
cbacc9aa 251 SAVESPTR(PL_comppad_name);
dd2155a4
DM
252 SAVEI32(PL_padix);
253 SAVEI32(PL_comppad_name_fill);
254 SAVEI32(PL_min_intro_pending);
255 SAVEI32(PL_max_intro_pending);
8bbe96d7 256 SAVEBOOL(PL_cv_has_eval);
dd2155a4 257 if (flags & padnew_SAVESUB) {
f0cb02e3 258 SAVEBOOL(PL_pad_reset_pending);
dd2155a4
DM
259 }
260 }
261 }
262 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
263 * saved - check at some pt that this is okay */
264
265 /* ... create new pad ... */
266
7261499d 267 Newxz(padlist, 1, PADLIST);
dd2155a4
DM
268 pad = newAV();
269
270 if (flags & padnew_CLONE) {
271 /* XXX DAPM I dont know why cv_clone needs it
272 * doing differently yet - perhaps this separate branch can be
273 * dispensed with eventually ???
274 */
275
e1ec3a88 276 AV * const a0 = newAV(); /* will be @_ */
ad64d0ec 277 av_store(pad, 0, MUTABLE_SV(a0));
11ca45c0 278 AvREIFY_only(a0);
9ef8d569
FC
279
280 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
dd2155a4
DM
281 }
282 else {
db4cf31d 283 padlist->xpadl_id = PL_padlist_generation++;
a0714e2c 284 av_store(pad, 0, NULL);
9ef8d569 285 padname = newAV();
dd2155a4
DM
286 }
287
7a6072a8
NC
288 /* Most subroutines never recurse, hence only need 2 entries in the padlist
289 array - names, and depth=1. The default for av_store() is to allocate
290 0..3, and even an explicit call to av_extend() with <3 will be rounded
291 up, so we inline the allocation of the array here. */
7261499d 292 Newx(ary, 2, PAD *);
86d2498c
FC
293 PadlistMAX(padlist) = 1;
294 PadlistARRAY(padlist) = ary;
7261499d
FC
295 ary[0] = padname;
296 ary[1] = pad;
dd2155a4
DM
297
298 /* ... then update state variables */
299
403799bf
NC
300 PL_comppad = pad;
301 PL_curpad = AvARRAY(pad);
dd2155a4
DM
302
303 if (! (flags & padnew_CLONE)) {
9ef8d569 304 PL_comppad_name = padname;
dd2155a4
DM
305 PL_comppad_name_fill = 0;
306 PL_min_intro_pending = 0;
307 PL_padix = 0;
b5c19bd7 308 PL_cv_has_eval = 0;
dd2155a4
DM
309 }
310
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
b5c19bd7 312 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
dd2155a4 313 " name=0x%"UVxf" flags=0x%"UVxf"\n",
b5c19bd7 314 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
dd2155a4
DM
315 PTR2UV(padname), (UV)flags
316 )
317 );
318
319 return (PADLIST*)padlist;
320}
321
dd2155a4 322
c4528262
NC
323/*
324=head1 Embedding Functions
325
326=for apidoc cv_undef
327
328Clear out all the active components of a CV. This can happen either
329by an explicit C<undef &foo>, or by the reference count going to zero.
330In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
331children can still follow the full lexical scope chain.
332
333=cut
334*/
335
336void
337Perl_cv_undef(pTHX_ CV *cv)
338{
339 dVAR;
c2736fce 340 const PADLIST *padlist = CvPADLIST(cv);
8be227ab 341 bool const slabbed = !!CvSLABBED(cv);
c4528262
NC
342
343 PERL_ARGS_ASSERT_CV_UNDEF;
344
345 DEBUG_X(PerlIO_printf(Perl_debug_log,
346 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
347 PTR2UV(cv), PTR2UV(PL_comppad))
348 );
349
bad4ae38 350 if (CvFILE(cv) && CvDYNFILE(cv)) {
c4528262
NC
351 Safefree(CvFILE(cv));
352 }
353 CvFILE(cv) = NULL;
dd2155a4 354
8be227ab 355 CvSLABBED_off(cv);
c4528262
NC
356 if (!CvISXSUB(cv) && CvROOT(cv)) {
357 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
358 Perl_croak(aTHX_ "Can't undef active subroutine");
359 ENTER;
360
361 PAD_SAVE_SETNULLPAD();
362
8be227ab 363 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
c4528262
NC
364 op_free(CvROOT(cv));
365 CvROOT(cv) = NULL;
366 CvSTART(cv) = NULL;
367 LEAVE;
368 }
8be227ab
FC
369 else if (slabbed && CvSTART(cv)) {
370 ENTER;
371 PAD_SAVE_SETNULLPAD();
372
373 /* discard any leaked ops */
374 opslab_force_free((OPSLAB *)CvSTART(cv));
375 CvSTART(cv) = NULL;
376
377 LEAVE;
378 }
7aef8e5b 379#ifdef DEBUGGING
8be227ab 380 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
8be227ab 381#endif
c4528262 382 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
2f14e398 383 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
b290562e
FC
384 if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv));
385 else CvGV_set(cv, NULL);
c4528262 386
c2736fce
NC
387 /* This statement and the subsequence if block was pad_undef(). */
388 pad_peg("pad_undef");
389
7261499d 390 if (padlist) {
c2736fce
NC
391 I32 ix;
392
393 /* Free the padlist associated with a CV.
394 If parts of it happen to be current, we null the relevant PL_*pad*
395 global vars so that we don't have any dangling references left.
396 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
397 subs to the outer of this cv. */
398
399 DEBUG_X(PerlIO_printf(Perl_debug_log,
400 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
401 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
402 );
403
404 /* detach any '&' anon children in the pad; if afterwards they
405 * are still live, fix up their CvOUTSIDEs to point to our outside,
406 * bypassing us. */
407 /* XXX DAPM for efficiency, we should only do this if we know we have
408 * children, or integrate this loop with general cleanup */
409
410 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
411 CV * const outercv = CvOUTSIDE(cv);
412 const U32 seq = CvOUTSIDE_SEQ(cv);
86d2498c 413 PAD * const comppad_name = PadlistARRAY(padlist)[0];
c2736fce 414 SV ** const namepad = AvARRAY(comppad_name);
86d2498c 415 PAD * const comppad = PadlistARRAY(padlist)[1];
c2736fce
NC
416 SV ** const curpad = AvARRAY(comppad);
417 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
418 SV * const namesv = namepad[ix];
419 if (namesv && namesv != &PL_sv_undef
420 && *SvPVX_const(namesv) == '&')
421 {
422 CV * const innercv = MUTABLE_CV(curpad[ix]);
423 U32 inner_rc = SvREFCNT(innercv);
424 assert(inner_rc);
e09ac076 425 assert(SvTYPE(innercv) != SVt_PVFM);
c2736fce
NC
426
427 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
428 curpad[ix] = NULL;
429 SvREFCNT_dec(innercv);
430 inner_rc--;
431 }
432
433 /* in use, not just a prototype */
434 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
435 assert(CvWEAKOUTSIDE(innercv));
436 /* don't relink to grandfather if he's being freed */
437 if (outercv && SvREFCNT(outercv)) {
438 CvWEAKOUTSIDE_off(innercv);
439 CvOUTSIDE(innercv) = outercv;
440 CvOUTSIDE_SEQ(innercv) = seq;
441 SvREFCNT_inc_simple_void_NN(outercv);
442 }
443 else {
444 CvOUTSIDE(innercv) = NULL;
445 }
446 }
447 }
448 }
449 }
450
86d2498c 451 ix = PadlistMAX(padlist);
aa2f79cf 452 while (ix > 0) {
86d2498c 453 PAD * const sv = PadlistARRAY(padlist)[ix--];
c2736fce 454 if (sv) {
7261499d 455 if (sv == PL_comppad) {
c2736fce
NC
456 PL_comppad = NULL;
457 PL_curpad = NULL;
458 }
aa2f79cf 459 SvREFCNT_dec(sv);
c2736fce 460 }
aa2f79cf
NC
461 }
462 {
86d2498c 463 PAD * const sv = PadlistARRAY(padlist)[0];
9ef8d569 464 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
aa2f79cf 465 PL_comppad_name = NULL;
c2736fce
NC
466 SvREFCNT_dec(sv);
467 }
86d2498c 468 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
7261499d 469 Safefree(padlist);
c2736fce
NC
470 CvPADLIST(cv) = NULL;
471 }
472
c4528262
NC
473
474 /* remove CvOUTSIDE unless this is an undef rather than a free */
475 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
476 if (!CvWEAKOUTSIDE(cv))
477 SvREFCNT_dec(CvOUTSIDE(cv));
478 CvOUTSIDE(cv) = NULL;
479 }
480 if (CvCONST(cv)) {
481 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
482 CvCONST_off(cv);
483 }
484 if (CvISXSUB(cv) && CvXSUB(cv)) {
485 CvXSUB(cv) = NULL;
486 }
487 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
2c374370
FC
488 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
489 * to choose an error message */
490 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
c4528262 491}
dd2155a4 492
50dc2bd3
FC
493/*
494=for apidoc cv_forget_slab
495
496When a CV has a reference count on its slab (CvSLABBED), it is responsible
497for making sure it is freed. (Hence, no two CVs should ever have a
498reference count on the same slab.) The CV only needs to reference the slab
499during compilation. Once it is compiled and CvROOT attached, it has
500finished its job, so it can forget the slab.
501
502=cut
503*/
504
8be227ab
FC
505void
506Perl_cv_forget_slab(pTHX_ CV *cv)
507{
508 const bool slabbed = !!CvSLABBED(cv);
3107b51f 509 OPSLAB *slab = NULL;
8be227ab
FC
510
511 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
512
513 if (!slabbed) return;
514
515 CvSLABBED_off(cv);
516
3107b51f
FC
517 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
518 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
7aef8e5b 519#ifdef DEBUGGING
8be227ab 520 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
7aef8e5b 521#endif
3107b51f 522
3107b51f 523 if (slab) {
f3e29105
NC
524#ifdef PERL_DEBUG_READONLY_OPS
525 const size_t refcnt = slab->opslab_refcnt;
526#endif
3107b51f 527 OpslabREFCNT_dec(slab);
f3e29105 528#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 529 if (refcnt > 1) Slab_to_ro(slab);
8be227ab 530#endif
f3e29105 531 }
7aef8e5b 532}
8be227ab 533
cc76b5cc
Z
534/*
535=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
536
1a115e49
FC
537Allocates a place in the currently-compiling
538pad (via L<perlapi/pad_alloc>) and
cc76b5cc
Z
539then stores a name for that entry. I<namesv> is adopted and becomes the
540name entry; it must already contain the name string and be sufficiently
541upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
1a115e49
FC
542added to I<namesv>. None of the other
543processing of L<perlapi/pad_add_name_pvn>
cc76b5cc
Z
544is done. Returns the offset of the allocated pad slot.
545
546=cut
547*/
548
3291825f 549static PADOFFSET
cc76b5cc 550S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
3291825f
NC
551{
552 dVAR;
553 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
554
cc76b5cc 555 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
3291825f 556
cc76b5cc 557 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
3291825f
NC
558
559 if (typestash) {
560 assert(SvTYPE(namesv) == SVt_PVMG);
561 SvPAD_TYPED_on(namesv);
562 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
563 }
564 if (ourstash) {
565 SvPAD_OUR_on(namesv);
566 SvOURSTASH_set(namesv, ourstash);
567 SvREFCNT_inc_simple_void_NN(ourstash);
568 }
59cfed7d 569 else if (flags & padadd_STATE) {
3291825f
NC
570 SvPAD_STATE_on(namesv);
571 }
572
573 av_store(PL_comppad_name, offset, namesv);
574 return offset;
575}
576
dd2155a4 577/*
cc76b5cc 578=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
dd2155a4 579
cc76b5cc
Z
580Allocates a place in the currently-compiling pad for a named lexical
581variable. Stores the name and other metadata in the name part of the
582pad, and makes preparations to manage the variable's lexical scoping.
583Returns the offset of the allocated pad slot.
dd2155a4 584
cc76b5cc
Z
585I<namepv>/I<namelen> specify the variable's name, including leading sigil.
586If I<typestash> is non-null, the name is for a typed lexical, and this
587identifies the type. If I<ourstash> is non-null, it's a lexical reference
588to a package variable, and this identifies the package. The following
589flags can be OR'ed together:
590
591 padadd_OUR redundantly specifies if it's a package var
592 padadd_STATE variable will retain value persistently
593 padadd_NO_DUP_CHECK skip check for lexical shadowing
dd2155a4
DM
594
595=cut
596*/
597
dd2155a4 598PADOFFSET
cc76b5cc
Z
599Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
600 U32 flags, HV *typestash, HV *ourstash)
dd2155a4 601{
97aff369 602 dVAR;
3291825f 603 PADOFFSET offset;
cca43f78 604 SV *namesv;
e8b34487 605 bool is_utf8;
dd2155a4 606
cc76b5cc 607 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
7918f24d 608
2435e5d3 609 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
cc76b5cc 610 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
cca43f78
NC
611 (UV)flags);
612
613 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
e8b34487
BF
614
615 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
616 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
617 }
618
0727928e
BF
619 sv_setpvn(namesv, namepv, namelen);
620
e8b34487
BF
621 if (is_utf8) {
622 flags |= padadd_UTF8_NAME;
623 SvUTF8_on(namesv);
624 }
625 else
626 flags &= ~padadd_UTF8_NAME;
dd2155a4 627
59cfed7d 628 if ((flags & padadd_NO_DUP_CHECK) == 0) {
2d12d04f 629 /* check for duplicate declaration */
59cfed7d 630 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
2d12d04f
NC
631 }
632
2435e5d3 633 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
3291825f
NC
634
635 /* not yet introduced */
2df5bdd7
DM
636 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
637 COP_SEQ_RANGE_HIGH_set(namesv, 0);
3291825f
NC
638
639 if (!PL_min_intro_pending)
640 PL_min_intro_pending = offset;
641 PL_max_intro_pending = offset;
642 /* if it's not a simple scalar, replace with an AV or HV */
c1bf42f3
NC
643 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
644 assert(SvREFCNT(PL_curpad[offset]) == 1);
cc76b5cc 645 if (namelen != 0 && *namepv == '@')
c1bf42f3 646 sv_upgrade(PL_curpad[offset], SVt_PVAV);
cc76b5cc 647 else if (namelen != 0 && *namepv == '%')
c1bf42f3
NC
648 sv_upgrade(PL_curpad[offset], SVt_PVHV);
649 assert(SvPADMY(PL_curpad[offset]));
3291825f
NC
650 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
651 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
cc76b5cc
Z
652 (long)offset, SvPVX(namesv),
653 PTR2UV(PL_curpad[offset])));
dd2155a4
DM
654
655 return offset;
656}
657
cc76b5cc
Z
658/*
659=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 660
cc76b5cc
Z
661Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
662instead of a string/length pair.
dd2155a4 663
cc76b5cc
Z
664=cut
665*/
666
667PADOFFSET
668Perl_pad_add_name_pv(pTHX_ const char *name,
0e1b3a4b 669 const U32 flags, HV *typestash, HV *ourstash)
cc76b5cc
Z
670{
671 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
672 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
673}
dd2155a4
DM
674
675/*
cc76b5cc 676=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 677
cc76b5cc
Z
678Exactly like L</pad_add_name_pvn>, but takes the name string in the form
679of an SV instead of a string/length pair.
680
681=cut
682*/
683
684PADOFFSET
685Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
686{
687 char *namepv;
688 STRLEN namelen;
689 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
690 namepv = SvPV(name, namelen);
e8b34487
BF
691 if (SvUTF8(name))
692 flags |= padadd_UTF8_NAME;
cc76b5cc
Z
693 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
694}
695
696/*
697=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
698
699Allocates a place in the currently-compiling pad,
700returning the offset of the allocated pad slot.
701No name is initially attached to the pad slot.
702I<tmptype> is a set of flags indicating the kind of pad entry required,
703which will be set in the value SV for the allocated pad entry:
704
705 SVs_PADMY named lexical variable ("my", "our", "state")
706 SVs_PADTMP unnamed temporary store
707
708I<optype> should be an opcode indicating the type of operation that the
709pad entry is to support. This doesn't affect operational semantics,
710but is used for debugging.
dd2155a4
DM
711
712=cut
713*/
714
715/* XXX DAPM integrate alloc(), add_name() and add_anon(),
716 * or at least rationalise ??? */
dd2155a4
DM
717
718PADOFFSET
719Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
720{
97aff369 721 dVAR;
dd2155a4
DM
722 SV *sv;
723 I32 retval;
724
6136c704 725 PERL_UNUSED_ARG(optype);
f3548bdc
DM
726 ASSERT_CURPAD_ACTIVE("pad_alloc");
727
dd2155a4 728 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
729 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
730 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
731 if (PL_pad_reset_pending)
732 pad_reset();
733 if (tmptype & SVs_PADMY) {
cc76b5cc 734 /* For a my, simply push a null SV onto the end of PL_comppad. */
235cc2e3 735 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
dd2155a4
DM
736 retval = AvFILLp(PL_comppad);
737 }
738 else {
cc76b5cc
Z
739 /* For a tmp, scan the pad from PL_padix upwards
740 * for a slot which has no name and no active value.
741 */
551405c4 742 SV * const * const names = AvARRAY(PL_comppad_name);
e1ec3a88 743 const SSize_t names_fill = AvFILLp(PL_comppad_name);
dd2155a4
DM
744 for (;;) {
745 /*
746 * "foreach" index vars temporarily become aliases to non-"my"
747 * values. Thus we must skip, not just pad values that are
748 * marked as current pad values, but also those with names.
749 */
750 /* HVDS why copy to sv here? we don't seem to use it */
751 if (++PL_padix <= names_fill &&
752 (sv = names[PL_padix]) && sv != &PL_sv_undef)
753 continue;
754 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
755 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
756 !IS_PADGV(sv) && !IS_PADCONST(sv))
757 break;
758 }
759 retval = PL_padix;
760 }
761 SvFLAGS(sv) |= tmptype;
762 PL_curpad = AvARRAY(PL_comppad);
763
764 DEBUG_X(PerlIO_printf(Perl_debug_log,
765 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
766 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
767 PL_op_name[optype]));
fd0854ff
DM
768#ifdef DEBUG_LEAKING_SCALARS
769 sv->sv_debug_optype = optype;
770 sv->sv_debug_inpad = 1;
fd0854ff 771#endif
a212c8b5 772 return (PADOFFSET)retval;
dd2155a4
DM
773}
774
775/*
cc76b5cc 776=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
dd2155a4 777
cc76b5cc
Z
778Allocates a place in the currently-compiling pad (via L</pad_alloc>)
779for an anonymous function that is lexically scoped inside the
780currently-compiling function.
781The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
782to the outer scope is weakened to avoid a reference loop.
783
84eea980
FC
784One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
785
cc76b5cc
Z
786I<optype> should be an opcode indicating the type of operation that the
787pad entry is to support. This doesn't affect operational semantics,
788but is used for debugging.
dd2155a4
DM
789
790=cut
791*/
792
793PADOFFSET
cc76b5cc 794Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
dd2155a4 795{
97aff369 796 dVAR;
dd2155a4 797 PADOFFSET ix;
b9f83d2f 798 SV* const name = newSV_type(SVt_PVNV);
7918f24d
NC
799
800 PERL_ARGS_ASSERT_PAD_ADD_ANON;
801
1dba731d 802 pad_peg("add_anon");
76f68e9b 803 sv_setpvs(name, "&");
0d311cdb
DM
804 /* These two aren't used; just make sure they're not equal to
805 * PERL_PADSEQ_INTRO */
806 COP_SEQ_RANGE_LOW_set(name, 0);
807 COP_SEQ_RANGE_HIGH_set(name, 0);
cc76b5cc 808 ix = pad_alloc(optype, SVs_PADMY);
dd2155a4 809 av_store(PL_comppad_name, ix, name);
f3548bdc 810 /* XXX DAPM use PL_curpad[] ? */
e09ac076
FC
811 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
812 av_store(PL_comppad, ix, (SV*)func);
813 else {
7c93c29b 814 SV *rv = newRV_noinc((SV *)func);
e09ac076
FC
815 sv_rvweaken(rv);
816 assert (SvTYPE(func) == SVt_PVFM);
817 av_store(PL_comppad, ix, rv);
818 }
cc76b5cc 819 SvPADMY_on((SV*)func);
7dafbf52
DM
820
821 /* to avoid ref loops, we never have parent + child referencing each
822 * other simultaneously */
e09ac076 823 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
cc76b5cc
Z
824 assert(!CvWEAKOUTSIDE(func));
825 CvWEAKOUTSIDE_on(func);
826 SvREFCNT_dec(CvOUTSIDE(func));
7dafbf52 827 }
dd2155a4
DM
828 return ix;
829}
830
dd2155a4 831/*
13087dd8 832=for apidoc pad_check_dup
dd2155a4
DM
833
834Check for duplicate declarations: report any of:
13087dd8 835
dd2155a4 836 * a my in the current scope with the same name;
13087dd8
FC
837 * an our (anywhere in the pad) with the same name and the
838 same stash as C<ourstash>
839
840C<is_our> indicates that the name to check is an 'our' declaration.
dd2155a4
DM
841
842=cut
843*/
844
20381b50 845STATIC void
cc76b5cc 846S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
dd2155a4 847{
97aff369 848 dVAR;
53c1dcc0 849 SV **svp;
dd2155a4 850 PADOFFSET top, off;
59cfed7d 851 const U32 is_our = flags & padadd_OUR;
dd2155a4 852
7918f24d
NC
853 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
854
f3548bdc 855 ASSERT_CURPAD_ACTIVE("pad_check_dup");
35f82371 856
59cfed7d 857 assert((flags & ~padadd_OUR) == 0);
35f82371 858
041457d9 859 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
dd2155a4
DM
860 return; /* nothing to check */
861
862 svp = AvARRAY(PL_comppad_name);
863 top = AvFILLp(PL_comppad_name);
864 /* check the current scope */
865 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
866 * type ? */
867 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
53c1dcc0
AL
868 SV * const sv = svp[off];
869 if (sv
dd2155a4 870 && sv != &PL_sv_undef
ee6cee0c 871 && !SvFAKE(sv)
0d311cdb
DM
872 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
873 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
2d12d04f 874 && sv_eq(name, sv))
dd2155a4 875 {
00b1698f 876 if (is_our && (SvPAD_OUR(sv)))
7f73a9f1 877 break; /* "our" masking "our" */
dd2155a4 878 Perl_warner(aTHX_ packWARN(WARN_MISC),
c541b9b4 879 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
12bd6ede 880 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
c541b9b4 881 sv,
2df5bdd7
DM
882 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
883 ? "scope" : "statement"));
dd2155a4
DM
884 --off;
885 break;
886 }
887 }
888 /* check the rest of the pad */
889 if (is_our) {
61c5492a 890 while (off > 0) {
53c1dcc0
AL
891 SV * const sv = svp[off];
892 if (sv
dd2155a4 893 && sv != &PL_sv_undef
ee6cee0c 894 && !SvFAKE(sv)
0d311cdb
DM
895 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
896 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
73d95100 897 && SvOURSTASH(sv) == ourstash
2d12d04f 898 && sv_eq(name, sv))
dd2155a4
DM
899 {
900 Perl_warner(aTHX_ packWARN(WARN_MISC),
c541b9b4 901 "\"our\" variable %"SVf" redeclared", sv);
624f69f5 902 if ((I32)off <= PL_comppad_name_floor)
7f73a9f1
RGS
903 Perl_warner(aTHX_ packWARN(WARN_MISC),
904 "\t(Did you mean \"local\" instead of \"our\"?)\n");
dd2155a4
DM
905 break;
906 }
61c5492a
NC
907 --off;
908 }
dd2155a4
DM
909 }
910}
911
912
dd2155a4 913/*
cc76b5cc 914=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
dd2155a4 915
cc76b5cc
Z
916Given the name of a lexical variable, find its position in the
917currently-compiling pad.
918I<namepv>/I<namelen> specify the variable's name, including leading sigil.
919I<flags> is reserved and must be zero.
920If it is not in the current pad but appears in the pad of any lexically
921enclosing scope, then a pseudo-entry for it is added in the current pad.
922Returns the offset in the current pad,
923or C<NOT_IN_PAD> if no such lexical is in scope.
dd2155a4
DM
924
925=cut
926*/
927
928PADOFFSET
cc76b5cc 929Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
dd2155a4 930{
97aff369 931 dVAR;
b5c19bd7
DM
932 SV *out_sv;
933 int out_flags;
929a0744 934 I32 offset;
e1ec3a88 935 const AV *nameav;
929a0744 936 SV **name_svp;
dd2155a4 937
cc76b5cc 938 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
7918f24d 939
cc76b5cc 940 pad_peg("pad_findmy_pvn");
f8f98e0a 941
2435e5d3 942 if (flags & ~padadd_UTF8_NAME)
cc76b5cc 943 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
f8f98e0a
NC
944 (UV)flags);
945
e8b34487
BF
946 if (flags & padadd_UTF8_NAME) {
947 bool is_utf8 = TRUE;
948 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
949
950 if (is_utf8)
951 flags |= padadd_UTF8_NAME;
952 else
953 flags &= ~padadd_UTF8_NAME;
954 }
955
fbb889c8
BF
956 offset = pad_findlex(namepv, namelen, flags,
957 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
9f7d9405 958 if ((PADOFFSET)offset != NOT_IN_PAD)
929a0744
DM
959 return offset;
960
961 /* look for an our that's being introduced; this allows
962 * our $foo = 0 unless defined $foo;
963 * to not give a warning. (Yes, this is a hack) */
964
86d2498c 965 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
929a0744
DM
966 name_svp = AvARRAY(nameav);
967 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 968 const SV * const namesv = name_svp[offset];
929a0744
DM
969 if (namesv && namesv != &PL_sv_undef
970 && !SvFAKE(namesv)
00b1698f 971 && (SvPAD_OUR(namesv))
cc76b5cc 972 && SvCUR(namesv) == namelen
e8b34487
BF
973 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
974 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
2df5bdd7 975 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
929a0744
DM
976 )
977 return offset;
978 }
979 return NOT_IN_PAD;
dd2155a4
DM
980}
981
e1f795dc 982/*
cc76b5cc
Z
983=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
984
985Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
986instead of a string/length pair.
987
988=cut
989*/
990
991PADOFFSET
992Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
993{
994 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
995 return pad_findmy_pvn(name, strlen(name), flags);
996}
997
998/*
999=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1000
1001Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1002of an SV instead of a string/length pair.
1003
1004=cut
1005*/
1006
1007PADOFFSET
1008Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1009{
1010 char *namepv;
1011 STRLEN namelen;
1012 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1013 namepv = SvPV(name, namelen);
2435e5d3
BF
1014 if (SvUTF8(name))
1015 flags |= padadd_UTF8_NAME;
cc76b5cc
Z
1016 return pad_findmy_pvn(namepv, namelen, flags);
1017}
1018
1019/*
1020=for apidoc Amp|PADOFFSET|find_rundefsvoffset
1021
1022Find the position of the lexical C<$_> in the pad of the
1023currently-executing function. Returns the offset in the current pad,
1024or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1025the global one should be used instead).
1026L</find_rundefsv> is likely to be more convenient.
1027
1028=cut
1029*/
e1f795dc
RGS
1030
1031PADOFFSET
29289021 1032Perl_find_rundefsvoffset(pTHX)
e1f795dc 1033{
97aff369 1034 dVAR;
e1f795dc
RGS
1035 SV *out_sv;
1036 int out_flags;
fbb889c8 1037 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
4608196e 1038 NULL, &out_sv, &out_flags);
e1f795dc 1039}
dd2155a4 1040
dd2155a4 1041/*
cc76b5cc
Z
1042=for apidoc Am|SV *|find_rundefsv
1043
1044Find and return the variable that is named C<$_> in the lexical scope
1045of the currently-executing function. This may be a lexical C<$_>,
1046or will otherwise be the global one.
1047
1048=cut
1049*/
789bd863
VP
1050
1051SV *
1052Perl_find_rundefsv(pTHX)
1053{
1054 SV *namesv;
1055 int flags;
1056 PADOFFSET po;
1057
fbb889c8 1058 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
789bd863
VP
1059 NULL, &namesv, &flags);
1060
1979170b 1061 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
789bd863
VP
1062 return DEFSV;
1063
1064 return PAD_SVl(po);
1065}
1066
c086f97a
FC
1067SV *
1068Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1069{
1070 SV *namesv;
1071 int flags;
1072 PADOFFSET po;
1073
1074 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1075
1076 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1077 NULL, &namesv, &flags);
1078
1079 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1080 return DEFSV;
1081
86d2498c 1082 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
c086f97a
FC
1083}
1084
789bd863 1085/*
fbb889c8 1086=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
dd2155a4
DM
1087
1088Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
1089in the inner pads if it's found in an outer one.
1090
1091Returns the offset in the bottom pad of the lex or the fake lex.
1092cv is the CV in which to start the search, and seq is the current cop_seq
1093to match against. If warn is true, print appropriate warnings. The out_*
1094vars return values, and so are pointers to where the returned values
1095should be stored. out_capture, if non-null, requests that the innermost
1096instance of the lexical is captured; out_name_sv is set to the innermost
1097matched namesv or fake namesv; out_flags returns the flags normally
1098associated with the IVX field of a fake namesv.
1099
1100Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1101then comes back down, adding fake entries as it goes. It has to be this way
3441fb63 1102because fake namesvs in anon protoypes have to store in xlow the index into
b5c19bd7 1103the parent pad.
dd2155a4
DM
1104
1105=cut
1106*/
1107
b5c19bd7
DM
1108/* the CV has finished being compiled. This is not a sufficient test for
1109 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1110#define CvCOMPILED(cv) CvROOT(cv)
1111
71f882da
DM
1112/* the CV does late binding of its lexicals */
1113#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1114
b5c19bd7 1115
dd2155a4 1116STATIC PADOFFSET
fbb889c8 1117S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
cc76b5cc 1118 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
dd2155a4 1119{
97aff369 1120 dVAR;
b5c19bd7
DM
1121 I32 offset, new_offset;
1122 SV *new_capture;
1123 SV **new_capturep;
b70d5558 1124 const PADLIST * const padlist = CvPADLIST(cv);
7ef30830 1125 const bool staleok = !!(flags & padadd_STALEOK);
dd2155a4 1126
7918f24d
NC
1127 PERL_ARGS_ASSERT_PAD_FINDLEX;
1128
7ef30830 1129 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
2435e5d3
BF
1130 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1131 (UV)flags);
7ef30830 1132 flags &= ~ padadd_STALEOK; /* one-shot flag */
2435e5d3 1133
b5c19bd7 1134 *out_flags = 0;
a3985cdc 1135
b5c19bd7 1136 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
cc76b5cc 1137 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
4c760560 1138 PTR2UV(cv), (int)namelen, namepv, (int)seq,
cc76b5cc 1139 out_capture ? " capturing" : "" ));
dd2155a4 1140
b5c19bd7 1141 /* first, search this pad */
dd2155a4 1142
b5c19bd7
DM
1143 if (padlist) { /* not an undef CV */
1144 I32 fake_offset = 0;
86d2498c 1145 const AV * const nameav = PadlistARRAY(padlist)[0];
551405c4 1146 SV * const * const name_svp = AvARRAY(nameav);
ee6cee0c 1147
b5c19bd7 1148 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 1149 const SV * const namesv = name_svp[offset];
b5c19bd7 1150 if (namesv && namesv != &PL_sv_undef
cc76b5cc 1151 && SvCUR(namesv) == namelen
e8b34487
BF
1152 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1153 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
b5c19bd7 1154 {
6012dc80 1155 if (SvFAKE(namesv)) {
b5c19bd7 1156 fake_offset = offset; /* in case we don't find a real one */
6012dc80
DM
1157 continue;
1158 }
1159 /* is seq within the range _LOW to _HIGH ?
1160 * This is complicated by the fact that PL_cop_seqmax
1161 * may have wrapped around at some point */
1162 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1163 continue; /* not yet introduced */
1164
1165 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1166 /* in compiling scope */
1167 if (
1168 (seq > COP_SEQ_RANGE_LOW(namesv))
1169 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1170 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1171 )
1172 break;
1173 }
1174 else if (
1175 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1176 ?
1177 ( seq > COP_SEQ_RANGE_LOW(namesv)
1178 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1179
1180 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1181 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1182 )
1183 break;
ee6cee0c
DM
1184 }
1185 }
1186
b5c19bd7
DM
1187 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1188 if (offset > 0) { /* not fake */
1189 fake_offset = 0;
1190 *out_name_sv = name_svp[offset]; /* return the namesv */
1191
1192 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1193 * instances. For now, we just test !CvUNIQUE(cv), but
1194 * ideally, we should detect my's declared within loops
1195 * etc - this would allow a wider range of 'not stayed
486ec47a 1196 * shared' warnings. We also treated already-compiled
b5c19bd7
DM
1197 * lexes as not multi as viewed from evals. */
1198
1199 *out_flags = CvANON(cv) ?
1200 PAD_FAKELEX_ANON :
1201 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1202 ? PAD_FAKELEX_MULTI : 0;
1203
1204 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02
NC
1205 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1206 PTR2UV(cv), (long)offset,
1207 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1208 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
b5c19bd7
DM
1209 }
1210 else { /* fake match */
1211 offset = fake_offset;
1212 *out_name_sv = name_svp[offset]; /* return the namesv */
809abb02 1213 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
b5c19bd7 1214 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
19a5c512 1215 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7 1216 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
809abb02 1217 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
b5c19bd7
DM
1218 ));
1219 }
dd2155a4 1220
b5c19bd7 1221 /* return the lex? */
dd2155a4 1222
b5c19bd7 1223 if (out_capture) {
dd2155a4 1224
b5c19bd7 1225 /* our ? */
00b1698f 1226 if (SvPAD_OUR(*out_name_sv)) {
a0714e2c 1227 *out_capture = NULL;
b5c19bd7
DM
1228 return offset;
1229 }
ee6cee0c 1230
b5c19bd7
DM
1231 /* trying to capture from an anon prototype? */
1232 if (CvCOMPILED(cv)
1233 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1234 : *out_flags & PAD_FAKELEX_ANON)
1235 {
a2a5de95
NC
1236 if (warn)
1237 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1238 "Variable \"%"SVf"\" is not available",
1239 newSVpvn_flags(namepv, namelen,
1240 SVs_TEMP |
1241 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1242
a0714e2c 1243 *out_capture = NULL;
b5c19bd7 1244 }
ee6cee0c 1245
b5c19bd7
DM
1246 /* real value */
1247 else {
1248 int newwarn = warn;
1249 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
d1186544 1250 && !SvPAD_STATE(name_svp[offset])
b5c19bd7
DM
1251 && warn && ckWARN(WARN_CLOSURE)) {
1252 newwarn = 0;
1253 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1254 "Variable \"%"SVf"\" will not stay shared",
1255 newSVpvn_flags(namepv, namelen,
1256 SVs_TEMP |
1257 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
b5c19bd7 1258 }
dd2155a4 1259
b5c19bd7
DM
1260 if (fake_offset && CvANON(cv)
1261 && CvCLONE(cv) &&!CvCLONED(cv))
1262 {
1263 SV *n;
1264 /* not yet caught - look further up */
1265 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1266 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1267 PTR2UV(cv)));
1268 n = *out_name_sv;
fbb889c8 1269 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
282e1742 1270 CvOUTSIDE_SEQ(cv),
b5c19bd7
DM
1271 newwarn, out_capture, out_name_sv, out_flags);
1272 *out_name_sv = n;
1273 return offset;
dd2155a4 1274 }
b5c19bd7 1275
86d2498c 1276 *out_capture = AvARRAY(PadlistARRAY(padlist)[
7261499d 1277 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
b5c19bd7
DM
1278 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1279 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 1280 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7 1281
d1186544 1282 if (SvPADSTALE(*out_capture)
7ef30830 1283 && (!CvDEPTH(cv) || !staleok)
d1186544
DM
1284 && !SvPAD_STATE(name_svp[offset]))
1285 {
a2a5de95 1286 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1287 "Variable \"%"SVf"\" is not available",
1288 newSVpvn_flags(namepv, namelen,
1289 SVs_TEMP |
1290 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
a0714e2c 1291 *out_capture = NULL;
dd2155a4
DM
1292 }
1293 }
b5c19bd7 1294 if (!*out_capture) {
cc76b5cc 1295 if (namelen != 0 && *namepv == '@')
ad64d0ec 1296 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
cc76b5cc 1297 else if (namelen != 0 && *namepv == '%')
ad64d0ec 1298 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
b5c19bd7
DM
1299 else
1300 *out_capture = sv_newmortal();
1301 }
dd2155a4 1302 }
b5c19bd7
DM
1303
1304 return offset;
ee6cee0c 1305 }
b5c19bd7
DM
1306 }
1307
1308 /* it's not in this pad - try above */
1309
1310 if (!CvOUTSIDE(cv))
1311 return NOT_IN_PAD;
9f7d9405 1312
b5c19bd7 1313 /* out_capture non-null means caller wants us to capture lex; in
71f882da 1314 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 1315 new_capturep = out_capture ? out_capture :
4608196e 1316 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7 1317
7ef30830
FC
1318 offset = pad_findlex(namepv, namelen,
1319 flags | padadd_STALEOK*(new_capturep == &new_capture),
1320 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
b5c19bd7 1321 new_capturep, out_name_sv, out_flags);
9f7d9405 1322 if ((PADOFFSET)offset == NOT_IN_PAD)
b5c19bd7 1323 return NOT_IN_PAD;
9f7d9405 1324
b5c19bd7
DM
1325 /* found in an outer CV. Add appropriate fake entry to this pad */
1326
1327 /* don't add new fake entries (via eval) to CVs that we have already
1328 * finished compiling, or to undef CVs */
1329 if (CvCOMPILED(cv) || !padlist)
1330 return 0; /* this dummy (and invalid) value isnt used by the caller */
1331
1332 {
3291825f 1333 /* This relies on sv_setsv_flags() upgrading the destination to the same
486ec47a 1334 type as the source, independent of the flags set, and on it being
3291825f
NC
1335 "good" and only copying flag bits and pointers that it understands.
1336 */
1337 SV *new_namesv = newSVsv(*out_name_sv);
53c1dcc0
AL
1338 AV * const ocomppad_name = PL_comppad_name;
1339 PAD * const ocomppad = PL_comppad;
86d2498c
FC
1340 PL_comppad_name = PadlistARRAY(padlist)[0];
1341 PL_comppad = PadlistARRAY(padlist)[1];
b5c19bd7
DM
1342 PL_curpad = AvARRAY(PL_comppad);
1343
3291825f 1344 new_offset
cc76b5cc 1345 = pad_alloc_name(new_namesv,
59cfed7d 1346 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
3291825f
NC
1347 SvPAD_TYPED(*out_name_sv)
1348 ? SvSTASH(*out_name_sv) : NULL,
1349 SvOURSTASH(*out_name_sv)
1350 );
1351
1352 SvFAKE_on(new_namesv);
1353 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1354 "Pad addname: %ld \"%.*s\" FAKE\n",
1355 (long)new_offset,
1356 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
809abb02 1357 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
b5c19bd7 1358
809abb02 1359 PARENT_PAD_INDEX_set(new_namesv, 0);
00b1698f 1360 if (SvPAD_OUR(new_namesv)) {
6f207bd3 1361 NOOP; /* do nothing */
b5c19bd7 1362 }
71f882da 1363 else if (CvLATE(cv)) {
b5c19bd7 1364 /* delayed creation - just note the offset within parent pad */
809abb02 1365 PARENT_PAD_INDEX_set(new_namesv, offset);
b5c19bd7
DM
1366 CvCLONE_on(cv);
1367 }
1368 else {
1369 /* immediate creation - capture outer value right now */
1370 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1371 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1372 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1373 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 1374 }
b5c19bd7 1375 *out_name_sv = new_namesv;
809abb02 1376 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
b5c19bd7
DM
1377
1378 PL_comppad_name = ocomppad_name;
1379 PL_comppad = ocomppad;
4608196e 1380 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 1381 }
b5c19bd7 1382 return new_offset;
dd2155a4
DM
1383}
1384
fb8a9836 1385#ifdef DEBUGGING
cc76b5cc 1386
dd2155a4 1387/*
cc76b5cc 1388=for apidoc Am|SV *|pad_sv|PADOFFSET po
dd2155a4 1389
cc76b5cc 1390Get the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1391Use macro PAD_SV instead of calling this function directly.
1392
1393=cut
1394*/
1395
dd2155a4
DM
1396SV *
1397Perl_pad_sv(pTHX_ PADOFFSET po)
1398{
97aff369 1399 dVAR;
f3548bdc 1400 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 1401
dd2155a4
DM
1402 if (!po)
1403 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
1404 DEBUG_X(PerlIO_printf(Perl_debug_log,
1405 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 1406 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
1407 );
1408 return PL_curpad[po];
1409}
1410
dd2155a4 1411/*
cc76b5cc 1412=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
dd2155a4 1413
cc76b5cc 1414Set the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1415Use the macro PAD_SETSV() rather than calling this function directly.
1416
1417=cut
1418*/
1419
dd2155a4
DM
1420void
1421Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1422{
97aff369 1423 dVAR;
7918f24d
NC
1424
1425 PERL_ARGS_ASSERT_PAD_SETSV;
1426
f3548bdc 1427 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
1428
1429 DEBUG_X(PerlIO_printf(Perl_debug_log,
1430 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 1431 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
1432 );
1433 PL_curpad[po] = sv;
1434}
dd2155a4 1435
cc76b5cc 1436#endif /* DEBUGGING */
dd2155a4
DM
1437
1438/*
cc76b5cc 1439=for apidoc m|void|pad_block_start|int full
dd2155a4 1440
e89fca5e 1441Update the pad compilation state variables on entry to a new block.
dd2155a4
DM
1442
1443=cut
1444*/
1445
1446/* XXX DAPM perhaps:
1447 * - integrate this in general state-saving routine ???
1448 * - combine with the state-saving going on in pad_new ???
1449 * - introduce a new SAVE type that does all this in one go ?
1450 */
1451
1452void
1453Perl_pad_block_start(pTHX_ int full)
1454{
97aff369 1455 dVAR;
f3548bdc 1456 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4
DM
1457 SAVEI32(PL_comppad_name_floor);
1458 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1459 if (full)
1460 PL_comppad_name_fill = PL_comppad_name_floor;
1461 if (PL_comppad_name_floor < 0)
1462 PL_comppad_name_floor = 0;
1463 SAVEI32(PL_min_intro_pending);
1464 SAVEI32(PL_max_intro_pending);
1465 PL_min_intro_pending = 0;
1466 SAVEI32(PL_comppad_name_fill);
1467 SAVEI32(PL_padix_floor);
1468 PL_padix_floor = PL_padix;
1469 PL_pad_reset_pending = FALSE;
1470}
1471
dd2155a4 1472/*
cc76b5cc 1473=for apidoc m|U32|intro_my
dd2155a4 1474
bf954566
FC
1475"Introduce" my variables to visible status. This is called during parsing
1476at the end of each statement to make lexical variables visible to
1477subsequent statements.
dd2155a4
DM
1478
1479=cut
1480*/
1481
1482U32
1483Perl_intro_my(pTHX)
1484{
97aff369 1485 dVAR;
dd2155a4 1486 SV **svp;
dd2155a4 1487 I32 i;
6012dc80 1488 U32 seq;
dd2155a4 1489
f3548bdc 1490 ASSERT_CURPAD_ACTIVE("intro_my");
dd2155a4
DM
1491 if (! PL_min_intro_pending)
1492 return PL_cop_seqmax;
1493
1494 svp = AvARRAY(PL_comppad_name);
1495 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
53c1dcc0
AL
1496 SV * const sv = svp[i];
1497
0d311cdb
DM
1498 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1499 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1500 {
2df5bdd7 1501 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
809abb02 1502 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1503 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1504 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1505 (long)i, SvPVX_const(sv),
809abb02
NC
1506 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1507 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1508 );
1509 }
1510 }
6012dc80
DM
1511 seq = PL_cop_seqmax;
1512 PL_cop_seqmax++;
1513 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1514 PL_cop_seqmax++;
dd2155a4
DM
1515 PL_min_intro_pending = 0;
1516 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1517 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
6012dc80 1518 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
dd2155a4 1519
6012dc80 1520 return seq;
dd2155a4
DM
1521}
1522
1523/*
cc76b5cc 1524=for apidoc m|void|pad_leavemy
dd2155a4
DM
1525
1526Cleanup at end of scope during compilation: set the max seq number for
1527lexicals in this scope and warn of any lexicals that never got introduced.
1528
1529=cut
1530*/
1531
1532void
1533Perl_pad_leavemy(pTHX)
1534{
97aff369 1535 dVAR;
dd2155a4 1536 I32 off;
551405c4 1537 SV * const * const svp = AvARRAY(PL_comppad_name);
dd2155a4
DM
1538
1539 PL_pad_reset_pending = FALSE;
1540
f3548bdc 1541 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1542 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1543 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
53c1dcc0 1544 const SV * const sv = svp[off];
9b387841
NC
1545 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1546 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1547 "%"SVf" never introduced",
1548 SVfARG(sv));
dd2155a4
DM
1549 }
1550 }
1551 /* "Deintroduce" my variables that are leaving with this scope. */
1552 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
53c1dcc0 1553 const SV * const sv = svp[off];
2df5bdd7
DM
1554 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
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",
b15aece3 1560 (long)off, SvPVX_const(sv),
809abb02
NC
1561 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1562 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1563 );
1564 }
1565 }
1566 PL_cop_seqmax++;
6012dc80
DM
1567 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1568 PL_cop_seqmax++;
dd2155a4
DM
1569 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1570 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1571}
1572
dd2155a4 1573/*
cc76b5cc 1574=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
dd2155a4
DM
1575
1576Abandon the tmp in the current pad at offset po and replace with a
1577new one.
1578
1579=cut
1580*/
1581
1582void
1583Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1584{
97aff369 1585 dVAR;
f3548bdc 1586 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1587 if (!PL_curpad)
1588 return;
1589 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1590 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1591 AvARRAY(PL_comppad), PL_curpad);
9100eeb1
Z
1592 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1593 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1594 (long)po, (long)AvFILLp(PL_comppad));
dd2155a4
DM
1595
1596 DEBUG_X(PerlIO_printf(Perl_debug_log,
1597 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1598 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1599
1600 if (PL_curpad[po])
1601 SvPADTMP_off(PL_curpad[po]);
1602 if (refadjust)
1603 SvREFCNT_dec(PL_curpad[po]);
1604
9ad9869c
DM
1605
1606 /* if pad tmps aren't shared between ops, then there's no need to
1607 * create a new tmp when an existing op is freed */
1608#ifdef USE_BROKEN_PAD_RESET
561b68a9 1609 PL_curpad[po] = newSV(0);
dd2155a4 1610 SvPADTMP_on(PL_curpad[po]);
9ad9869c
DM
1611#else
1612 PL_curpad[po] = &PL_sv_undef;
97bf4a8d 1613#endif
dd2155a4
DM
1614 if ((I32)po < PL_padix)
1615 PL_padix = po - 1;
1616}
1617
dd2155a4 1618/*
cc76b5cc 1619=for apidoc m|void|pad_reset
dd2155a4
DM
1620
1621Mark all the current temporaries for reuse
1622
1623=cut
1624*/
1625
1626/* XXX pad_reset() is currently disabled because it results in serious bugs.
1627 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1628 * on the stack by OPs that use them, there are several ways to get an alias
1629 * to a shared TARG. Such an alias will change randomly and unpredictably.
1630 * We avoid doing this until we can think of a Better Way.
1631 * GSAR 97-10-29 */
1f676739 1632static void
82af08ae 1633S_pad_reset(pTHX)
dd2155a4 1634{
97aff369 1635 dVAR;
dd2155a4 1636#ifdef USE_BROKEN_PAD_RESET
dd2155a4 1637 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1638 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1639 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1640
1641 DEBUG_X(PerlIO_printf(Perl_debug_log,
1642 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1643 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1644 (long)PL_padix, (long)PL_padix_floor
1645 )
1646 );
1647
1648 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
eb578fdb 1649 I32 po;
dd2155a4
DM
1650 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1651 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1652 SvPADTMP_off(PL_curpad[po]);
1653 }
1654 PL_padix = PL_padix_floor;
1655 }
1656#endif
1657 PL_pad_reset_pending = FALSE;
1658}
1659
dd2155a4 1660/*
cc76b5cc
Z
1661=for apidoc Amx|void|pad_tidy|padtidy_type type
1662
1663Tidy up a pad at the end of compilation of the code to which it belongs.
1664Jobs performed here are: remove most stuff from the pads of anonsub
1665prototypes; give it a @_; mark temporaries as such. I<type> indicates
1666the kind of subroutine:
dd2155a4 1667
cc76b5cc
Z
1668 padtidy_SUB ordinary subroutine
1669 padtidy_SUBCLONE prototype for lexical closure
1670 padtidy_FORMAT format
dd2155a4
DM
1671
1672=cut
1673*/
1674
1675/* XXX DAPM surely most of this stuff should be done properly
1676 * at the right time beforehand, rather than going around afterwards
1677 * cleaning up our mistakes ???
1678 */
1679
1680void
1681Perl_pad_tidy(pTHX_ padtidy_type type)
1682{
27da23d5 1683 dVAR;
dd2155a4 1684
f3548bdc 1685 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1686
1687 /* If this CV has had any 'eval-capable' ops planted in it
1688 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1689 * anon prototypes in the chain of CVs should be marked as cloneable,
1690 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1691 * the right CvOUTSIDE.
1692 * If running with -d, *any* sub may potentially have an eval
486ec47a 1693 * executed within it.
b5c19bd7
DM
1694 */
1695
1696 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1697 const CV *cv;
b5c19bd7
DM
1698 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1699 if (cv != PL_compcv && CvCOMPILED(cv))
1700 break; /* no need to mark already-compiled code */
1701 if (CvANON(cv)) {
1702 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1703 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1704 CvCLONE_on(cv);
a0d2bbd5 1705 CvHASEVAL_on(cv);
b5c19bd7
DM
1706 }
1707 }
1708 }
1709
dd2155a4
DM
1710 /* extend curpad to match namepad */
1711 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
a0714e2c 1712 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1713
1714 if (type == padtidy_SUBCLONE) {
551405c4 1715 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1716 PADOFFSET ix;
b5c19bd7 1717
dd2155a4
DM
1718 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1719 SV *namesv;
1720
1721 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1722 continue;
1723 /*
1724 * The only things that a clonable function needs in its
b5c19bd7 1725 * pad are anonymous subs.
dd2155a4
DM
1726 * The rest are created anew during cloning.
1727 */
a0714e2c 1728 if (!((namesv = namep[ix]) != NULL &&
dd2155a4 1729 namesv != &PL_sv_undef &&
b15aece3 1730 *SvPVX_const(namesv) == '&'))
dd2155a4
DM
1731 {
1732 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1733 PL_curpad[ix] = NULL;
dd2155a4
DM
1734 }
1735 }
1736 }
1737 else if (type == padtidy_SUB) {
1738 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
53c1dcc0 1739 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1740 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1741 AvREIFY_only(av);
dd2155a4
DM
1742 }
1743
4cee4ca8 1744 if (type == padtidy_SUB || type == padtidy_FORMAT) {
adf8f095 1745 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1746 PADOFFSET ix;
dd2155a4
DM
1747 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1748 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1749 continue;
adf8f095 1750 if (!SvPADMY(PL_curpad[ix])) {
dd2155a4 1751 SvPADTMP_on(PL_curpad[ix]);
adf8f095
NC
1752 } else if (!SvFAKE(namep[ix])) {
1753 /* This is a work around for how the current implementation of
1754 ?{ } blocks in regexps interacts with lexicals.
1755
1756 One of our lexicals.
1757 Can't do this on all lexicals, otherwise sub baz() won't
1758 compile in
1759
1760 my $foo;
1761
1762 sub bar { ++$foo; }
1763
1764 sub baz { ++$foo; }
1765
1766 because completion of compiling &bar calling pad_tidy()
1767 would cause (top level) $foo to be marked as stale, and
1768 "no longer available". */
1769 SvPADSTALE_on(PL_curpad[ix]);
1770 }
dd2155a4
DM
1771 }
1772 }
f3548bdc 1773 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1774}
1775
dd2155a4 1776/*
cc76b5cc 1777=for apidoc m|void|pad_free|PADOFFSET po
dd2155a4 1778
8627550a 1779Free the SV at offset po in the current pad.
dd2155a4
DM
1780
1781=cut
1782*/
1783
1784/* XXX DAPM integrate with pad_swipe ???? */
1785void
1786Perl_pad_free(pTHX_ PADOFFSET po)
1787{
97aff369 1788 dVAR;
f3548bdc 1789 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1790 if (!PL_curpad)
1791 return;
1792 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1793 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1794 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1795 if (!po)
1796 Perl_croak(aTHX_ "panic: pad_free po");
1797
1798 DEBUG_X(PerlIO_printf(Perl_debug_log,
1799 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1800 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1801 );
1802
1803 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
9a214eec 1804 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
dd2155a4
DM
1805 }
1806 if ((I32)po < PL_padix)
1807 PL_padix = po - 1;
1808}
1809
dd2155a4 1810/*
cc76b5cc 1811=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
dd2155a4
DM
1812
1813Dump the contents of a padlist
1814
1815=cut
1816*/
1817
1818void
1819Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1820{
97aff369 1821 dVAR;
e1ec3a88
AL
1822 const AV *pad_name;
1823 const AV *pad;
dd2155a4
DM
1824 SV **pname;
1825 SV **ppad;
dd2155a4
DM
1826 I32 ix;
1827
7918f24d
NC
1828 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1829
dd2155a4
DM
1830 if (!padlist) {
1831 return;
1832 }
86d2498c
FC
1833 pad_name = *PadlistARRAY(padlist);
1834 pad = PadlistARRAY(padlist)[1];
dd2155a4
DM
1835 pname = AvARRAY(pad_name);
1836 ppad = AvARRAY(pad);
1837 Perl_dump_indent(aTHX_ level, file,
1838 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1839 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1840 );
1841
1842 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1843 const SV *namesv = pname[ix];
dd2155a4 1844 if (namesv && namesv == &PL_sv_undef) {
a0714e2c 1845 namesv = NULL;
dd2155a4
DM
1846 }
1847 if (namesv) {
ee6cee0c
DM
1848 if (SvFAKE(namesv))
1849 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1850 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1851 (int) ix,
1852 PTR2UV(ppad[ix]),
1853 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b15aece3 1854 SvPVX_const(namesv),
809abb02
NC
1855 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1856 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1857
ee6cee0c
DM
1858 );
1859 else
1860 Perl_dump_indent(aTHX_ level+1, file,
809abb02 1861 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1862 (int) ix,
1863 PTR2UV(ppad[ix]),
1864 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1865 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1866 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
b15aece3 1867 SvPVX_const(namesv)
ee6cee0c 1868 );
dd2155a4
DM
1869 }
1870 else if (full) {
1871 Perl_dump_indent(aTHX_ level+1, file,
1872 "%2d. 0x%"UVxf"<%lu>\n",
1873 (int) ix,
1874 PTR2UV(ppad[ix]),
1875 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1876 );
1877 }
1878 }
1879}
1880
cc76b5cc 1881#ifdef DEBUGGING
dd2155a4
DM
1882
1883/*
cc76b5cc 1884=for apidoc m|void|cv_dump|CV *cv|const char *title
dd2155a4
DM
1885
1886dump the contents of a CV
1887
1888=cut
1889*/
1890
dd2155a4 1891STATIC void
e1ec3a88 1892S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1893{
97aff369 1894 dVAR;
53c1dcc0 1895 const CV * const outside = CvOUTSIDE(cv);
b70d5558 1896 PADLIST* const padlist = CvPADLIST(cv);
dd2155a4 1897
7918f24d
NC
1898 PERL_ARGS_ASSERT_CV_DUMP;
1899
dd2155a4
DM
1900 PerlIO_printf(Perl_debug_log,
1901 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1902 title,
1903 PTR2UV(cv),
1904 (CvANON(cv) ? "ANON"
71f882da 1905 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1906 : (cv == PL_main_cv) ? "MAIN"
1907 : CvUNIQUE(cv) ? "UNIQUE"
1908 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1909 PTR2UV(outside),
1910 (!outside ? "null"
1911 : CvANON(outside) ? "ANON"
1912 : (outside == PL_main_cv) ? "MAIN"
1913 : CvUNIQUE(outside) ? "UNIQUE"
1914 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1915
1916 PerlIO_printf(Perl_debug_log,
1917 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1918 do_dump_pad(1, Perl_debug_log, padlist, 1);
1919}
dd2155a4 1920
cc76b5cc 1921#endif /* DEBUGGING */
dd2155a4
DM
1922
1923/*
cc76b5cc 1924=for apidoc Am|CV *|cv_clone|CV *proto
dd2155a4 1925
cc76b5cc
Z
1926Clone a CV, making a lexical closure. I<proto> supplies the prototype
1927of the function: its code, pad structure, and other attributes.
1928The prototype is combined with a capture of outer lexicals to which the
1929code refers, which are taken from the currently-executing instance of
1930the immediately surrounding code.
dd2155a4
DM
1931
1932=cut
1933*/
1934
1935CV *
1936Perl_cv_clone(pTHX_ CV *proto)
1937{
27da23d5 1938 dVAR;
dd2155a4 1939 I32 ix;
b70d5558 1940 PADLIST* const protopadlist = CvPADLIST(proto);
9ef8d569 1941 PAD *const protopad_name = *PadlistARRAY(protopadlist);
86d2498c 1942 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
53c1dcc0
AL
1943 SV** const pname = AvARRAY(protopad_name);
1944 SV** const ppad = AvARRAY(protopad);
e1ec3a88
AL
1945 const I32 fname = AvFILLp(protopad_name);
1946 const I32 fpad = AvFILLp(protopad);
dd2155a4 1947 CV* cv;
b5c19bd7
DM
1948 SV** outpad;
1949 CV* outside;
71f882da 1950 long depth;
dd2155a4 1951
7918f24d
NC
1952 PERL_ARGS_ASSERT_CV_CLONE;
1953
dd2155a4
DM
1954 assert(!CvUNIQUE(proto));
1955
1b5aaca6
FC
1956 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1957 * reliable. The currently-running sub is always the one we need to
1958 * close over.
1959 * Note that in general for formats, CvOUTSIDE != find_runcv.
1960 * Since formats may be nested inside closures, CvOUTSIDE may point
71f882da 1961 * to a prototype; we instead want the cloned parent who called us.
af41786f 1962 */
71f882da 1963
5dff782d 1964 if (SvTYPE(proto) == SVt_PVCV)
71f882da 1965 outside = find_runcv(NULL);
5dff782d 1966 else {
af41786f 1967 outside = CvOUTSIDE(proto);
db4cf31d
FC
1968 if ((CvCLONE(outside) && ! CvCLONED(outside))
1969 || !CvPADLIST(outside)
1970 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1971 outside = find_runcv_where(
1972 FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
70794f7b 1973 );
db4cf31d 1974 /* outside could be null */
5dff782d
FC
1975 }
1976 }
db4cf31d 1977 depth = outside ? CvDEPTH(outside) : 0;
71f882da
DM
1978 assert(depth || SvTYPE(proto) == SVt_PVFM);
1979 if (!depth)
1980 depth = 1;
db4cf31d 1981 assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside));
b5c19bd7 1982
dd2155a4
DM
1983 ENTER;
1984 SAVESPTR(PL_compcv);
1985
ea726b52 1986 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
8be227ab
FC
1987 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1988 |CVf_SLABBED);
dd2155a4
DM
1989 CvCLONED_on(cv);
1990
bad4ae38
FC
1991 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1992 : CvFILE(proto);
b290562e
FC
1993 if (CvNAMED(proto))
1994 SvANY(cv)->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(proto));
1995 else CvGV_set(cv,CvGV(proto));
c68d9564 1996 CvSTASH_set(cv, CvSTASH(proto));
b34c0dd4 1997 OP_REFCNT_LOCK;
dd2155a4 1998 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1999 OP_REFCNT_UNLOCK;
dd2155a4 2000 CvSTART(cv) = CvSTART(proto);
a0d2bbd5
FC
2001 if (CvHASEVAL(cv))
2002 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
b5c19bd7 2003 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
2004
2005 if (SvPOK(proto))
ad64d0ec 2006 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
09fb282d
FC
2007 if (SvMAGIC(proto))
2008 mg_copy((SV *)proto, (SV *)cv, 0, 0);
dd2155a4 2009
cbacc9aa 2010 SAVESPTR(PL_comppad_name);
9ef8d569 2011 PL_comppad_name = protopad_name;
b7787f18 2012 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
db4cf31d 2013 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
dd2155a4 2014
b5c19bd7 2015 av_fill(PL_comppad, fpad);
dd2155a4 2016
dd2155a4
DM
2017 PL_curpad = AvARRAY(PL_comppad);
2018
db4cf31d 2019 outpad = outside && CvPADLIST(outside)
86d2498c 2020 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
f2ead8b8 2021 : NULL;
f91073d4 2022 assert(outpad || SvTYPE(cv) == SVt_PVFM);
db4cf31d 2023 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
b5c19bd7 2024
dd2155a4 2025 for (ix = fpad; ix > 0; ix--) {
a0714e2c
SS
2026 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2027 SV *sv = NULL;
71f882da 2028 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 2029 if (SvFAKE(namesv)) { /* lexical from outside? */
5aec98df
FC
2030 /* formats may have an inactive, or even undefined, parent;
2031 but state vars are always available. */
f2ead8b8 2032 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
cae5dbbe 2033 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
db4cf31d 2034 && (!outside || !CvDEPTH(outside))) ) {
f91073d4 2035 assert(SvTYPE(cv) == SVt_PVFM);
a2a5de95 2036 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e 2037 "Variable \"%"SVf"\" is not available", namesv);
a0714e2c 2038 sv = NULL;
71f882da 2039 }
33894c1a 2040 else
f84c484e 2041 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 2042 }
71f882da 2043 if (!sv) {
b15aece3 2044 const char sigil = SvPVX_const(namesv)[0];
e1ec3a88 2045 if (sigil == '&')
dd2155a4 2046 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 2047 else if (sigil == '@')
ad64d0ec 2048 sv = MUTABLE_SV(newAV());
e1ec3a88 2049 else if (sigil == '%')
ad64d0ec 2050 sv = MUTABLE_SV(newHV());
dd2155a4 2051 else
561b68a9 2052 sv = newSV(0);
235cc2e3 2053 SvPADMY_on(sv);
0d3b281c
DM
2054 /* reset the 'assign only once' flag on each state var */
2055 if (SvPAD_STATE(namesv))
2056 SvPADSTALE_on(sv);
dd2155a4
DM
2057 }
2058 }
2059 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
f84c484e 2060 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
2061 }
2062 else {
561b68a9 2063 sv = newSV(0);
dd2155a4 2064 SvPADTMP_on(sv);
dd2155a4 2065 }
71f882da 2066 PL_curpad[ix] = sv;
dd2155a4
DM
2067 }
2068
dd2155a4
DM
2069 DEBUG_Xv(
2070 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
db4cf31d 2071 if (outside) cv_dump(outside, "Outside");
dd2155a4
DM
2072 cv_dump(proto, "Proto");
2073 cv_dump(cv, "To");
2074 );
2075
2076 LEAVE;
2077
2078 if (CvCONST(cv)) {
b5c19bd7
DM
2079 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2080 * The prototype was marked as a candiate for const-ization,
2081 * so try to grab the current const value, and if successful,
2082 * turn into a const sub:
2083 */
551405c4 2084 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
2085 if (const_sv) {
2086 SvREFCNT_dec(cv);
be8851fc
NC
2087 /* For this calling case, op_const_sv returns a *copy*, which we
2088 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2089 Need to fix how lib/constant.pm works to eliminate this. */
bd61b366 2090 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
b5c19bd7
DM
2091 }
2092 else {
2093 CvCONST_off(cv);
2094 }
dd2155a4
DM
2095 }
2096
2097 return cv;
2098}
2099
dd2155a4 2100/*
cc76b5cc 2101=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
dd2155a4
DM
2102
2103For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
2104old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2105moved to a pre-existing CV struct.
dd2155a4
DM
2106
2107=cut
2108*/
2109
2110void
2111Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2112{
97aff369 2113 dVAR;
dd2155a4 2114 I32 ix;
86d2498c
FC
2115 AV * const comppad_name = PadlistARRAY(padlist)[0];
2116 AV * const comppad = PadlistARRAY(padlist)[1];
53c1dcc0
AL
2117 SV ** const namepad = AvARRAY(comppad_name);
2118 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
2119
2120 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
2121 PERL_UNUSED_ARG(old_cv);
2122
dd2155a4 2123 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
551405c4 2124 const SV * const namesv = namepad[ix];
09a30bc4 2125 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
b15aece3 2126 && *SvPVX_const(namesv) == '&')
dd2155a4 2127 {
e09ac076 2128 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
ea726b52 2129 CV * const innercv = MUTABLE_CV(curpad[ix]);
7dafbf52
DM
2130 assert(CvWEAKOUTSIDE(innercv));
2131 assert(CvOUTSIDE(innercv) == old_cv);
2132 CvOUTSIDE(innercv) = new_cv;
e09ac076
FC
2133 }
2134 else { /* format reference */
2135 SV * const rv = curpad[ix];
2136 CV *innercv;
2137 if (!SvOK(rv)) continue;
2138 assert(SvROK(rv));
2139 assert(SvWEAKREF(rv));
2140 innercv = (CV *)SvRV(rv);
2141 assert(!CvWEAKOUTSIDE(innercv));
2142 SvREFCNT_dec(CvOUTSIDE(innercv));
2143 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2144 }
dd2155a4
DM
2145 }
2146 }
2147}
2148
2149/*
cc76b5cc 2150=for apidoc m|void|pad_push|PADLIST *padlist|int depth
dd2155a4
DM
2151
2152Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
2153this depth, in which case don't bother creating a new one. Then give
2154the new pad an @_ in slot zero.
dd2155a4
DM
2155
2156=cut
2157*/
2158
2159void
26019298 2160Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2161{
97aff369 2162 dVAR;
7918f24d
NC
2163
2164 PERL_ARGS_ASSERT_PAD_PUSH;
2165
86d2498c
FC
2166 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2167 PAD** const svp = PadlistARRAY(padlist);
44f8325f
AL
2168 AV* const newpad = newAV();
2169 SV** const oldpad = AvARRAY(svp[depth-1]);
502c6561
NC
2170 I32 ix = AvFILLp((const AV *)svp[1]);
2171 const I32 names_fill = AvFILLp((const AV *)svp[0]);
44f8325f 2172 SV** const names = AvARRAY(svp[0]);
26019298
AL
2173 AV *av;
2174
dd2155a4
DM
2175 for ( ;ix > 0; ix--) {
2176 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
b15aece3 2177 const char sigil = SvPVX_const(names[ix])[0];
fda94784
RGS
2178 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2179 || (SvFLAGS(names[ix]) & SVpad_STATE)
2180 || sigil == '&')
2181 {
dd2155a4
DM
2182 /* outer lexical or anon code */
2183 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2184 }
2185 else { /* our own lexical */
26019298
AL
2186 SV *sv;
2187 if (sigil == '@')
ad64d0ec 2188 sv = MUTABLE_SV(newAV());
26019298 2189 else if (sigil == '%')
ad64d0ec 2190 sv = MUTABLE_SV(newHV());
dd2155a4 2191 else
561b68a9 2192 sv = newSV(0);
26019298 2193 av_store(newpad, ix, sv);
dd2155a4
DM
2194 SvPADMY_on(sv);
2195 }
2196 }
2197 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
f84c484e 2198 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2199 }
2200 else {
2201 /* save temporaries on recursion? */
561b68a9 2202 SV * const sv = newSV(0);
26019298 2203 av_store(newpad, ix, sv);
dd2155a4
DM
2204 SvPADTMP_on(sv);
2205 }
2206 }
26019298 2207 av = newAV();
ad64d0ec 2208 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2209 AvREIFY_only(av);
26019298 2210
7261499d 2211 padlist_store(padlist, depth, newpad);
dd2155a4
DM
2212 }
2213}
b21dc031 2214
cc76b5cc
Z
2215/*
2216=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2217
2218Looks up the type of the lexical variable at position I<po> in the
2219currently-compiling pad. If the variable is typed, the stash of the
2220class to which it is typed is returned. If not, C<NULL> is returned.
2221
2222=cut
2223*/
b21dc031
AL
2224
2225HV *
2226Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2227{
97aff369 2228 dVAR;
551405c4 2229 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
00b1698f 2230 if ( SvPAD_TYPED(*av) ) {
b21dc031
AL
2231 return SvSTASH(*av);
2232 }
5c284bb0 2233 return NULL;
b21dc031 2234}
66610fdd 2235
d5b1589c
NC
2236#if defined(USE_ITHREADS)
2237
2238# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2239
cc76b5cc 2240/*
b70d5558 2241=for apidoc padlist_dup
cc76b5cc
Z
2242
2243Duplicates a pad.
2244
2245=cut
2246*/
2247
b70d5558
FC
2248PADLIST *
2249Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
d5b1589c 2250{
7261499d
FC
2251 PADLIST *dstpad;
2252 bool cloneall;
2253 PADOFFSET max;
2254
d5b1589c
NC
2255 PERL_ARGS_ASSERT_PADLIST_DUP;
2256
2257 if (!srcpad)
2258 return NULL;
2259
7261499d 2260 cloneall = param->flags & CLONEf_COPY_STACKS
86d2498c
FC
2261 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2262 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
7261499d 2263
86d2498c 2264 max = cloneall ? PadlistMAX(srcpad) : 1;
7261499d
FC
2265
2266 Newx(dstpad, 1, PADLIST);
2267 ptr_table_store(PL_ptr_table, srcpad, dstpad);
86d2498c
FC
2268 PadlistMAX(dstpad) = max;
2269 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
7261499d
FC
2270
2271 if (cloneall) {
2272 PADOFFSET depth;
2273 for (depth = 0; depth <= max; ++depth)
86d2498c
FC
2274 PadlistARRAY(dstpad)[depth] =
2275 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
6de654a5
NC
2276 } else {
2277 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2278 to build anything other than the first level of pads. */
86d2498c 2279 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
6de654a5 2280 AV *pad1;
86d2498c
FC
2281 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2282 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
6de654a5
NC
2283 SV **oldpad = AvARRAY(srcpad1);
2284 SV **names;
2285 SV **pad1a;
2286 AV *args;
6de654a5 2287
86d2498c
FC
2288 PadlistARRAY(dstpad)[0] =
2289 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2290 names = AvARRAY(PadlistARRAY(dstpad)[0]);
6de654a5
NC
2291
2292 pad1 = newAV();
2293
2294 av_extend(pad1, ix);
86d2498c 2295 PadlistARRAY(dstpad)[1] = pad1;
6de654a5 2296 pad1a = AvARRAY(pad1);
6de654a5
NC
2297
2298 if (ix > -1) {
2299 AvFILLp(pad1) = ix;
2300
2301 for ( ;ix > 0; ix--) {
05d04d9c
NC
2302 if (!oldpad[ix]) {
2303 pad1a[ix] = NULL;
2304 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2305 const char sigil = SvPVX_const(names[ix])[0];
2306 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2307 || (SvFLAGS(names[ix]) & SVpad_STATE)
2308 || sigil == '&')
2309 {
2310 /* outer lexical or anon code */
2311 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2312 }
2313 else { /* our own lexical */
adf8f095
NC
2314 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2315 /* This is a work around for how the current
2316 implementation of ?{ } blocks in regexps
2317 interacts with lexicals. */
05d04d9c
NC
2318 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2319 } else {
2320 SV *sv;
2321
2322 if (sigil == '@')
2323 sv = MUTABLE_SV(newAV());
2324 else if (sigil == '%')
2325 sv = MUTABLE_SV(newHV());
2326 else
2327 sv = newSV(0);
2328 pad1a[ix] = sv;
2329 SvPADMY_on(sv);
2330 }
2331 }
2332 }
2333 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2334 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2335 }
2336 else {
2337 /* save temporaries on recursion? */
2338 SV * const sv = newSV(0);
2339 pad1a[ix] = sv;
2340
2341 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2342 FIXTHAT before merging this branch.
2343 (And I know how to) */
2344 if (SvPADMY(oldpad[ix]))
2345 SvPADMY_on(sv);
2346 else
2347 SvPADTMP_on(sv);
2348 }
6de654a5
NC
2349 }
2350
2351 if (oldpad[0]) {
2352 args = newAV(); /* Will be @_ */
2353 AvREIFY_only(args);
2354 pad1a[0] = (SV *)args;
2355 }
2356 }
2357 }
d5b1589c
NC
2358
2359 return dstpad;
2360}
2361
cc76b5cc 2362#endif /* USE_ITHREADS */
d5b1589c 2363
7261499d
FC
2364PAD **
2365Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
2366{
2367 dVAR;
2368 PAD **ary;
86d2498c 2369 SSize_t const oldmax = PadlistMAX(padlist);
7261499d
FC
2370
2371 PERL_ARGS_ASSERT_PADLIST_STORE;
2372
2373 assert(key >= 0);
2374
86d2498c
FC
2375 if (key > PadlistMAX(padlist)) {
2376 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2377 (SV ***)&PadlistARRAY(padlist),
2378 (SV ***)&PadlistARRAY(padlist));
2379 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
7261499d
FC
2380 PAD *);
2381 }
86d2498c 2382 ary = PadlistARRAY(padlist);
7261499d
FC
2383 SvREFCNT_dec(ary[key]);
2384 ary[key] = val;
2385 return &ary[key];
2386}
2387
66610fdd
RGS
2388/*
2389 * Local variables:
2390 * c-indentation-style: bsd
2391 * c-basic-offset: 4
14d04a33 2392 * indent-tabs-mode: nil
66610fdd
RGS
2393 * End:
2394 *
14d04a33 2395 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2396 */