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