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