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