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