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