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