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