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