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