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