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