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