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