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