This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Cleanup of pad fetching and storing. This version normalizes the data on both sides...
[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;
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
556 sv_setpvn(namesv, namepv, namelen);
557
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,
606 U32 flags, HV *typestash, HV *ourstash)
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
Z
1047 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1048 PTR2UV(cv), namelen, namepv, (int)seq,
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),
cc76b5cc
Z
1148 "Variable \"%.*s\" is not available",
1149 namelen, namepv);
a0714e2c 1150 *out_capture = NULL;
b5c19bd7 1151 }
ee6cee0c 1152
b5c19bd7
DM
1153 /* real value */
1154 else {
1155 int newwarn = warn;
1156 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
d1186544 1157 && !SvPAD_STATE(name_svp[offset])
b5c19bd7
DM
1158 && warn && ckWARN(WARN_CLOSURE)) {
1159 newwarn = 0;
1160 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
cc76b5cc
Z
1161 "Variable \"%.*s\" will not stay shared",
1162 namelen, namepv);
b5c19bd7 1163 }
dd2155a4 1164
b5c19bd7
DM
1165 if (fake_offset && CvANON(cv)
1166 && CvCLONE(cv) &&!CvCLONED(cv))
1167 {
1168 SV *n;
1169 /* not yet caught - look further up */
1170 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1171 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1172 PTR2UV(cv)));
1173 n = *out_name_sv;
fbb889c8 1174 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
282e1742 1175 CvOUTSIDE_SEQ(cv),
b5c19bd7
DM
1176 newwarn, out_capture, out_name_sv, out_flags);
1177 *out_name_sv = n;
1178 return offset;
dd2155a4 1179 }
b5c19bd7 1180
502c6561
NC
1181 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1182 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
b5c19bd7
DM
1183 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1184 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 1185 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7 1186
d1186544
DM
1187 if (SvPADSTALE(*out_capture)
1188 && !SvPAD_STATE(name_svp[offset]))
1189 {
a2a5de95 1190 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
cc76b5cc
Z
1191 "Variable \"%.*s\" is not available",
1192 namelen, namepv);
a0714e2c 1193 *out_capture = NULL;
dd2155a4
DM
1194 }
1195 }
b5c19bd7 1196 if (!*out_capture) {
cc76b5cc 1197 if (namelen != 0 && *namepv == '@')
ad64d0ec 1198 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
cc76b5cc 1199 else if (namelen != 0 && *namepv == '%')
ad64d0ec 1200 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
b5c19bd7
DM
1201 else
1202 *out_capture = sv_newmortal();
1203 }
dd2155a4 1204 }
b5c19bd7
DM
1205
1206 return offset;
ee6cee0c 1207 }
b5c19bd7
DM
1208 }
1209
1210 /* it's not in this pad - try above */
1211
1212 if (!CvOUTSIDE(cv))
1213 return NOT_IN_PAD;
9f7d9405 1214
b5c19bd7 1215 /* out_capture non-null means caller wants us to capture lex; in
71f882da 1216 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 1217 new_capturep = out_capture ? out_capture :
4608196e 1218 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7 1219
fbb889c8 1220 offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
b5c19bd7 1221 new_capturep, out_name_sv, out_flags);
9f7d9405 1222 if ((PADOFFSET)offset == NOT_IN_PAD)
b5c19bd7 1223 return NOT_IN_PAD;
9f7d9405 1224
b5c19bd7
DM
1225 /* found in an outer CV. Add appropriate fake entry to this pad */
1226
1227 /* don't add new fake entries (via eval) to CVs that we have already
1228 * finished compiling, or to undef CVs */
1229 if (CvCOMPILED(cv) || !padlist)
1230 return 0; /* this dummy (and invalid) value isnt used by the caller */
1231
1232 {
3291825f 1233 /* This relies on sv_setsv_flags() upgrading the destination to the same
486ec47a 1234 type as the source, independent of the flags set, and on it being
3291825f
NC
1235 "good" and only copying flag bits and pointers that it understands.
1236 */
1237 SV *new_namesv = newSVsv(*out_name_sv);
53c1dcc0
AL
1238 AV * const ocomppad_name = PL_comppad_name;
1239 PAD * const ocomppad = PL_comppad;
502c6561
NC
1240 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1241 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
b5c19bd7
DM
1242 PL_curpad = AvARRAY(PL_comppad);
1243
3291825f 1244 new_offset
cc76b5cc 1245 = pad_alloc_name(new_namesv,
59cfed7d 1246 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
3291825f
NC
1247 SvPAD_TYPED(*out_name_sv)
1248 ? SvSTASH(*out_name_sv) : NULL,
1249 SvOURSTASH(*out_name_sv)
1250 );
1251
1252 SvFAKE_on(new_namesv);
1253 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1254 "Pad addname: %ld \"%.*s\" FAKE\n",
1255 (long)new_offset,
1256 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
809abb02 1257 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
b5c19bd7 1258
809abb02 1259 PARENT_PAD_INDEX_set(new_namesv, 0);
00b1698f 1260 if (SvPAD_OUR(new_namesv)) {
6f207bd3 1261 NOOP; /* do nothing */
b5c19bd7 1262 }
71f882da 1263 else if (CvLATE(cv)) {
b5c19bd7 1264 /* delayed creation - just note the offset within parent pad */
809abb02 1265 PARENT_PAD_INDEX_set(new_namesv, offset);
b5c19bd7
DM
1266 CvCLONE_on(cv);
1267 }
1268 else {
1269 /* immediate creation - capture outer value right now */
1270 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1271 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1272 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1273 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 1274 }
b5c19bd7 1275 *out_name_sv = new_namesv;
809abb02 1276 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
b5c19bd7
DM
1277
1278 PL_comppad_name = ocomppad_name;
1279 PL_comppad = ocomppad;
4608196e 1280 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 1281 }
b5c19bd7 1282 return new_offset;
dd2155a4
DM
1283}
1284
fb8a9836 1285#ifdef DEBUGGING
cc76b5cc 1286
dd2155a4 1287/*
cc76b5cc 1288=for apidoc Am|SV *|pad_sv|PADOFFSET po
dd2155a4 1289
cc76b5cc 1290Get the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1291Use macro PAD_SV instead of calling this function directly.
1292
1293=cut
1294*/
1295
dd2155a4
DM
1296SV *
1297Perl_pad_sv(pTHX_ PADOFFSET po)
1298{
97aff369 1299 dVAR;
f3548bdc 1300 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 1301
dd2155a4
DM
1302 if (!po)
1303 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
1304 DEBUG_X(PerlIO_printf(Perl_debug_log,
1305 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 1306 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
1307 );
1308 return PL_curpad[po];
1309}
1310
dd2155a4 1311/*
cc76b5cc 1312=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
dd2155a4 1313
cc76b5cc 1314Set the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1315Use the macro PAD_SETSV() rather than calling this function directly.
1316
1317=cut
1318*/
1319
dd2155a4
DM
1320void
1321Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1322{
97aff369 1323 dVAR;
7918f24d
NC
1324
1325 PERL_ARGS_ASSERT_PAD_SETSV;
1326
f3548bdc 1327 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
1328
1329 DEBUG_X(PerlIO_printf(Perl_debug_log,
1330 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 1331 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
1332 );
1333 PL_curpad[po] = sv;
1334}
dd2155a4 1335
cc76b5cc 1336#endif /* DEBUGGING */
dd2155a4
DM
1337
1338/*
cc76b5cc 1339=for apidoc m|void|pad_block_start|int full
dd2155a4
DM
1340
1341Update the pad compilation state variables on entry to a new block
1342
1343=cut
1344*/
1345
1346/* XXX DAPM perhaps:
1347 * - integrate this in general state-saving routine ???
1348 * - combine with the state-saving going on in pad_new ???
1349 * - introduce a new SAVE type that does all this in one go ?
1350 */
1351
1352void
1353Perl_pad_block_start(pTHX_ int full)
1354{
97aff369 1355 dVAR;
f3548bdc 1356 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4
DM
1357 SAVEI32(PL_comppad_name_floor);
1358 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1359 if (full)
1360 PL_comppad_name_fill = PL_comppad_name_floor;
1361 if (PL_comppad_name_floor < 0)
1362 PL_comppad_name_floor = 0;
1363 SAVEI32(PL_min_intro_pending);
1364 SAVEI32(PL_max_intro_pending);
1365 PL_min_intro_pending = 0;
1366 SAVEI32(PL_comppad_name_fill);
1367 SAVEI32(PL_padix_floor);
1368 PL_padix_floor = PL_padix;
1369 PL_pad_reset_pending = FALSE;
1370}
1371
dd2155a4 1372/*
cc76b5cc 1373=for apidoc m|U32|intro_my
dd2155a4
DM
1374
1375"Introduce" my variables to visible status.
1376
1377=cut
1378*/
1379
1380U32
1381Perl_intro_my(pTHX)
1382{
97aff369 1383 dVAR;
dd2155a4 1384 SV **svp;
dd2155a4 1385 I32 i;
6012dc80 1386 U32 seq;
dd2155a4 1387
f3548bdc 1388 ASSERT_CURPAD_ACTIVE("intro_my");
dd2155a4
DM
1389 if (! PL_min_intro_pending)
1390 return PL_cop_seqmax;
1391
1392 svp = AvARRAY(PL_comppad_name);
1393 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
53c1dcc0
AL
1394 SV * const sv = svp[i];
1395
0d311cdb
DM
1396 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1397 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1398 {
2df5bdd7 1399 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
809abb02 1400 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1401 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1402 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1403 (long)i, SvPVX_const(sv),
809abb02
NC
1404 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1405 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1406 );
1407 }
1408 }
6012dc80
DM
1409 seq = PL_cop_seqmax;
1410 PL_cop_seqmax++;
1411 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1412 PL_cop_seqmax++;
dd2155a4
DM
1413 PL_min_intro_pending = 0;
1414 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1415 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
6012dc80 1416 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
dd2155a4 1417
6012dc80 1418 return seq;
dd2155a4
DM
1419}
1420
1421/*
cc76b5cc 1422=for apidoc m|void|pad_leavemy
dd2155a4
DM
1423
1424Cleanup at end of scope during compilation: set the max seq number for
1425lexicals in this scope and warn of any lexicals that never got introduced.
1426
1427=cut
1428*/
1429
1430void
1431Perl_pad_leavemy(pTHX)
1432{
97aff369 1433 dVAR;
dd2155a4 1434 I32 off;
551405c4 1435 SV * const * const svp = AvARRAY(PL_comppad_name);
dd2155a4
DM
1436
1437 PL_pad_reset_pending = FALSE;
1438
f3548bdc 1439 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1440 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1441 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
53c1dcc0 1442 const SV * const sv = svp[off];
9b387841
NC
1443 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1444 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1445 "%"SVf" never introduced",
1446 SVfARG(sv));
dd2155a4
DM
1447 }
1448 }
1449 /* "Deintroduce" my variables that are leaving with this scope. */
1450 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
53c1dcc0 1451 const SV * const sv = svp[off];
2df5bdd7
DM
1452 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1453 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1454 {
809abb02 1455 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
dd2155a4 1456 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1457 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1458 (long)off, SvPVX_const(sv),
809abb02
NC
1459 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1460 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1461 );
1462 }
1463 }
1464 PL_cop_seqmax++;
6012dc80
DM
1465 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1466 PL_cop_seqmax++;
dd2155a4
DM
1467 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1468 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1469}
1470
dd2155a4 1471/*
cc76b5cc 1472=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
dd2155a4
DM
1473
1474Abandon the tmp in the current pad at offset po and replace with a
1475new one.
1476
1477=cut
1478*/
1479
1480void
1481Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1482{
97aff369 1483 dVAR;
f3548bdc 1484 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1485 if (!PL_curpad)
1486 return;
1487 if (AvARRAY(PL_comppad) != PL_curpad)
1488 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1489 if (!po)
1490 Perl_croak(aTHX_ "panic: pad_swipe po");
1491
1492 DEBUG_X(PerlIO_printf(Perl_debug_log,
1493 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1494 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1495
1496 if (PL_curpad[po])
1497 SvPADTMP_off(PL_curpad[po]);
1498 if (refadjust)
1499 SvREFCNT_dec(PL_curpad[po]);
1500
9ad9869c
DM
1501
1502 /* if pad tmps aren't shared between ops, then there's no need to
1503 * create a new tmp when an existing op is freed */
1504#ifdef USE_BROKEN_PAD_RESET
561b68a9 1505 PL_curpad[po] = newSV(0);
dd2155a4 1506 SvPADTMP_on(PL_curpad[po]);
9ad9869c
DM
1507#else
1508 PL_curpad[po] = &PL_sv_undef;
97bf4a8d 1509#endif
dd2155a4
DM
1510 if ((I32)po < PL_padix)
1511 PL_padix = po - 1;
1512}
1513
dd2155a4 1514/*
cc76b5cc 1515=for apidoc m|void|pad_reset
dd2155a4
DM
1516
1517Mark all the current temporaries for reuse
1518
1519=cut
1520*/
1521
1522/* XXX pad_reset() is currently disabled because it results in serious bugs.
1523 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1524 * on the stack by OPs that use them, there are several ways to get an alias
1525 * to a shared TARG. Such an alias will change randomly and unpredictably.
1526 * We avoid doing this until we can think of a Better Way.
1527 * GSAR 97-10-29 */
1f676739 1528static void
82af08ae 1529S_pad_reset(pTHX)
dd2155a4 1530{
97aff369 1531 dVAR;
dd2155a4 1532#ifdef USE_BROKEN_PAD_RESET
dd2155a4
DM
1533 if (AvARRAY(PL_comppad) != PL_curpad)
1534 Perl_croak(aTHX_ "panic: pad_reset curpad");
1535
1536 DEBUG_X(PerlIO_printf(Perl_debug_log,
1537 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1538 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1539 (long)PL_padix, (long)PL_padix_floor
1540 )
1541 );
1542
1543 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
e1ec3a88 1544 register I32 po;
dd2155a4
DM
1545 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1546 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1547 SvPADTMP_off(PL_curpad[po]);
1548 }
1549 PL_padix = PL_padix_floor;
1550 }
1551#endif
1552 PL_pad_reset_pending = FALSE;
1553}
1554
dd2155a4 1555/*
cc76b5cc
Z
1556=for apidoc Amx|void|pad_tidy|padtidy_type type
1557
1558Tidy up a pad at the end of compilation of the code to which it belongs.
1559Jobs performed here are: remove most stuff from the pads of anonsub
1560prototypes; give it a @_; mark temporaries as such. I<type> indicates
1561the kind of subroutine:
dd2155a4 1562
cc76b5cc
Z
1563 padtidy_SUB ordinary subroutine
1564 padtidy_SUBCLONE prototype for lexical closure
1565 padtidy_FORMAT format
dd2155a4
DM
1566
1567=cut
1568*/
1569
1570/* XXX DAPM surely most of this stuff should be done properly
1571 * at the right time beforehand, rather than going around afterwards
1572 * cleaning up our mistakes ???
1573 */
1574
1575void
1576Perl_pad_tidy(pTHX_ padtidy_type type)
1577{
27da23d5 1578 dVAR;
dd2155a4 1579
f3548bdc 1580 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1581
1582 /* If this CV has had any 'eval-capable' ops planted in it
1583 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1584 * anon prototypes in the chain of CVs should be marked as cloneable,
1585 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1586 * the right CvOUTSIDE.
1587 * If running with -d, *any* sub may potentially have an eval
486ec47a 1588 * executed within it.
b5c19bd7
DM
1589 */
1590
1591 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1592 const CV *cv;
b5c19bd7
DM
1593 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1594 if (cv != PL_compcv && CvCOMPILED(cv))
1595 break; /* no need to mark already-compiled code */
1596 if (CvANON(cv)) {
1597 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1598 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1599 CvCLONE_on(cv);
1600 }
1601 }
1602 }
1603
dd2155a4
DM
1604 /* extend curpad to match namepad */
1605 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
a0714e2c 1606 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1607
1608 if (type == padtidy_SUBCLONE) {
551405c4 1609 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1610 PADOFFSET ix;
b5c19bd7 1611
dd2155a4
DM
1612 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1613 SV *namesv;
1614
1615 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1616 continue;
1617 /*
1618 * The only things that a clonable function needs in its
b5c19bd7 1619 * pad are anonymous subs.
dd2155a4
DM
1620 * The rest are created anew during cloning.
1621 */
a0714e2c 1622 if (!((namesv = namep[ix]) != NULL &&
dd2155a4 1623 namesv != &PL_sv_undef &&
b15aece3 1624 *SvPVX_const(namesv) == '&'))
dd2155a4
DM
1625 {
1626 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1627 PL_curpad[ix] = NULL;
dd2155a4
DM
1628 }
1629 }
1630 }
1631 else if (type == padtidy_SUB) {
1632 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
53c1dcc0 1633 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1634 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1635 AvREIFY_only(av);
dd2155a4
DM
1636 }
1637
4cee4ca8 1638 if (type == padtidy_SUB || type == padtidy_FORMAT) {
adf8f095 1639 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1640 PADOFFSET ix;
dd2155a4
DM
1641 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1642 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1643 continue;
adf8f095 1644 if (!SvPADMY(PL_curpad[ix])) {
dd2155a4 1645 SvPADTMP_on(PL_curpad[ix]);
adf8f095
NC
1646 } else if (!SvFAKE(namep[ix])) {
1647 /* This is a work around for how the current implementation of
1648 ?{ } blocks in regexps interacts with lexicals.
1649
1650 One of our lexicals.
1651 Can't do this on all lexicals, otherwise sub baz() won't
1652 compile in
1653
1654 my $foo;
1655
1656 sub bar { ++$foo; }
1657
1658 sub baz { ++$foo; }
1659
1660 because completion of compiling &bar calling pad_tidy()
1661 would cause (top level) $foo to be marked as stale, and
1662 "no longer available". */
1663 SvPADSTALE_on(PL_curpad[ix]);
1664 }
dd2155a4
DM
1665 }
1666 }
f3548bdc 1667 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1668}
1669
dd2155a4 1670/*
cc76b5cc 1671=for apidoc m|void|pad_free|PADOFFSET po
dd2155a4 1672
8627550a 1673Free the SV at offset po in the current pad.
dd2155a4
DM
1674
1675=cut
1676*/
1677
1678/* XXX DAPM integrate with pad_swipe ???? */
1679void
1680Perl_pad_free(pTHX_ PADOFFSET po)
1681{
97aff369 1682 dVAR;
f3548bdc 1683 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1684 if (!PL_curpad)
1685 return;
1686 if (AvARRAY(PL_comppad) != PL_curpad)
1687 Perl_croak(aTHX_ "panic: pad_free curpad");
1688 if (!po)
1689 Perl_croak(aTHX_ "panic: pad_free po");
1690
1691 DEBUG_X(PerlIO_printf(Perl_debug_log,
1692 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1693 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1694 );
1695
1696 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1697 SvPADTMP_off(PL_curpad[po]);
dd2155a4
DM
1698 }
1699 if ((I32)po < PL_padix)
1700 PL_padix = po - 1;
1701}
1702
dd2155a4 1703/*
cc76b5cc 1704=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
dd2155a4
DM
1705
1706Dump the contents of a padlist
1707
1708=cut
1709*/
1710
1711void
1712Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1713{
97aff369 1714 dVAR;
e1ec3a88
AL
1715 const AV *pad_name;
1716 const AV *pad;
dd2155a4
DM
1717 SV **pname;
1718 SV **ppad;
dd2155a4
DM
1719 I32 ix;
1720
7918f24d
NC
1721 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1722
dd2155a4
DM
1723 if (!padlist) {
1724 return;
1725 }
502c6561
NC
1726 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1727 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
dd2155a4
DM
1728 pname = AvARRAY(pad_name);
1729 ppad = AvARRAY(pad);
1730 Perl_dump_indent(aTHX_ level, file,
1731 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1732 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1733 );
1734
1735 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1736 const SV *namesv = pname[ix];
dd2155a4 1737 if (namesv && namesv == &PL_sv_undef) {
a0714e2c 1738 namesv = NULL;
dd2155a4
DM
1739 }
1740 if (namesv) {
ee6cee0c
DM
1741 if (SvFAKE(namesv))
1742 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1743 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1744 (int) ix,
1745 PTR2UV(ppad[ix]),
1746 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b15aece3 1747 SvPVX_const(namesv),
809abb02
NC
1748 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1749 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1750
ee6cee0c
DM
1751 );
1752 else
1753 Perl_dump_indent(aTHX_ level+1, file,
809abb02 1754 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1755 (int) ix,
1756 PTR2UV(ppad[ix]),
1757 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1758 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1759 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
b15aece3 1760 SvPVX_const(namesv)
ee6cee0c 1761 );
dd2155a4
DM
1762 }
1763 else if (full) {
1764 Perl_dump_indent(aTHX_ level+1, file,
1765 "%2d. 0x%"UVxf"<%lu>\n",
1766 (int) ix,
1767 PTR2UV(ppad[ix]),
1768 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1769 );
1770 }
1771 }
1772}
1773
cc76b5cc 1774#ifdef DEBUGGING
dd2155a4
DM
1775
1776/*
cc76b5cc 1777=for apidoc m|void|cv_dump|CV *cv|const char *title
dd2155a4
DM
1778
1779dump the contents of a CV
1780
1781=cut
1782*/
1783
dd2155a4 1784STATIC void
e1ec3a88 1785S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1786{
97aff369 1787 dVAR;
53c1dcc0
AL
1788 const CV * const outside = CvOUTSIDE(cv);
1789 AV* const padlist = CvPADLIST(cv);
dd2155a4 1790
7918f24d
NC
1791 PERL_ARGS_ASSERT_CV_DUMP;
1792
dd2155a4
DM
1793 PerlIO_printf(Perl_debug_log,
1794 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1795 title,
1796 PTR2UV(cv),
1797 (CvANON(cv) ? "ANON"
71f882da 1798 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1799 : (cv == PL_main_cv) ? "MAIN"
1800 : CvUNIQUE(cv) ? "UNIQUE"
1801 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1802 PTR2UV(outside),
1803 (!outside ? "null"
1804 : CvANON(outside) ? "ANON"
1805 : (outside == PL_main_cv) ? "MAIN"
1806 : CvUNIQUE(outside) ? "UNIQUE"
1807 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1808
1809 PerlIO_printf(Perl_debug_log,
1810 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1811 do_dump_pad(1, Perl_debug_log, padlist, 1);
1812}
dd2155a4 1813
cc76b5cc 1814#endif /* DEBUGGING */
dd2155a4
DM
1815
1816/*
cc76b5cc 1817=for apidoc Am|CV *|cv_clone|CV *proto
dd2155a4 1818
cc76b5cc
Z
1819Clone a CV, making a lexical closure. I<proto> supplies the prototype
1820of the function: its code, pad structure, and other attributes.
1821The prototype is combined with a capture of outer lexicals to which the
1822code refers, which are taken from the currently-executing instance of
1823the immediately surrounding code.
dd2155a4
DM
1824
1825=cut
1826*/
1827
1828CV *
1829Perl_cv_clone(pTHX_ CV *proto)
1830{
27da23d5 1831 dVAR;
dd2155a4 1832 I32 ix;
53c1dcc0 1833 AV* const protopadlist = CvPADLIST(proto);
502c6561
NC
1834 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1835 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
53c1dcc0
AL
1836 SV** const pname = AvARRAY(protopad_name);
1837 SV** const ppad = AvARRAY(protopad);
e1ec3a88
AL
1838 const I32 fname = AvFILLp(protopad_name);
1839 const I32 fpad = AvFILLp(protopad);
dd2155a4 1840 CV* cv;
b5c19bd7
DM
1841 SV** outpad;
1842 CV* outside;
71f882da 1843 long depth;
dd2155a4 1844
7918f24d
NC
1845 PERL_ARGS_ASSERT_CV_CLONE;
1846
dd2155a4
DM
1847 assert(!CvUNIQUE(proto));
1848
71f882da
DM
1849 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1850 * to a prototype; we instead want the cloned parent who called us.
1851 * Note that in general for formats, CvOUTSIDE != find_runcv */
1852
1853 outside = CvOUTSIDE(proto);
1854 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1855 outside = find_runcv(NULL);
1856 depth = CvDEPTH(outside);
1857 assert(depth || SvTYPE(proto) == SVt_PVFM);
1858 if (!depth)
1859 depth = 1;
b5c19bd7
DM
1860 assert(CvPADLIST(outside));
1861
dd2155a4
DM
1862 ENTER;
1863 SAVESPTR(PL_compcv);
1864
ea726b52 1865 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
c794ca97 1866 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
dd2155a4
DM
1867 CvCLONED_on(cv);
1868
dd2155a4 1869#ifdef USE_ITHREADS
aed2304a
NC
1870 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1871 : savepv(CvFILE(proto));
dd2155a4
DM
1872#else
1873 CvFILE(cv) = CvFILE(proto);
1874#endif
b3f91e91 1875 CvGV_set(cv,CvGV(proto));
c68d9564 1876 CvSTASH_set(cv, CvSTASH(proto));
b34c0dd4 1877 OP_REFCNT_LOCK;
dd2155a4 1878 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1879 OP_REFCNT_UNLOCK;
dd2155a4 1880 CvSTART(cv) = CvSTART(proto);
ea726b52 1881 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
b5c19bd7 1882 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
1883
1884 if (SvPOK(proto))
ad64d0ec 1885 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
dd2155a4 1886
b7787f18 1887 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
dd2155a4 1888
b5c19bd7 1889 av_fill(PL_comppad, fpad);
7aaef02a 1890 for (ix = fname; ix > 0; ix--)
dd2155a4
DM
1891 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1892
dd2155a4
DM
1893 PL_curpad = AvARRAY(PL_comppad);
1894
71f882da 1895 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
b5c19bd7 1896
dd2155a4 1897 for (ix = fpad; ix > 0; ix--) {
a0714e2c
SS
1898 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1899 SV *sv = NULL;
71f882da 1900 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 1901 if (SvFAKE(namesv)) { /* lexical from outside? */
809abb02 1902 sv = outpad[PARENT_PAD_INDEX(namesv)];
71f882da 1903 assert(sv);
33894c1a
DM
1904 /* formats may have an inactive parent,
1905 while my $x if $false can leave an active var marked as
d1186544
DM
1906 stale. And state vars are always available */
1907 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
a2a5de95
NC
1908 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1909 "Variable \"%s\" is not available", SvPVX_const(namesv));
a0714e2c 1910 sv = NULL;
71f882da 1911 }
33894c1a 1912 else
f84c484e 1913 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 1914 }
71f882da 1915 if (!sv) {
b15aece3 1916 const char sigil = SvPVX_const(namesv)[0];
e1ec3a88 1917 if (sigil == '&')
dd2155a4 1918 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 1919 else if (sigil == '@')
ad64d0ec 1920 sv = MUTABLE_SV(newAV());
e1ec3a88 1921 else if (sigil == '%')
ad64d0ec 1922 sv = MUTABLE_SV(newHV());
dd2155a4 1923 else
561b68a9 1924 sv = newSV(0);
235cc2e3 1925 SvPADMY_on(sv);
0d3b281c
DM
1926 /* reset the 'assign only once' flag on each state var */
1927 if (SvPAD_STATE(namesv))
1928 SvPADSTALE_on(sv);
dd2155a4
DM
1929 }
1930 }
1931 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
f84c484e 1932 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
1933 }
1934 else {
561b68a9 1935 sv = newSV(0);
dd2155a4 1936 SvPADTMP_on(sv);
dd2155a4 1937 }
71f882da 1938 PL_curpad[ix] = sv;
dd2155a4
DM
1939 }
1940
dd2155a4
DM
1941 DEBUG_Xv(
1942 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1943 cv_dump(outside, "Outside");
1944 cv_dump(proto, "Proto");
1945 cv_dump(cv, "To");
1946 );
1947
1948 LEAVE;
1949
1950 if (CvCONST(cv)) {
b5c19bd7
DM
1951 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1952 * The prototype was marked as a candiate for const-ization,
1953 * so try to grab the current const value, and if successful,
1954 * turn into a const sub:
1955 */
551405c4 1956 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
1957 if (const_sv) {
1958 SvREFCNT_dec(cv);
bd61b366 1959 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
b5c19bd7
DM
1960 }
1961 else {
1962 CvCONST_off(cv);
1963 }
dd2155a4
DM
1964 }
1965
1966 return cv;
1967}
1968
dd2155a4 1969/*
cc76b5cc 1970=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
dd2155a4
DM
1971
1972For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
1973old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1974moved to a pre-existing CV struct.
dd2155a4
DM
1975
1976=cut
1977*/
1978
1979void
1980Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1981{
97aff369 1982 dVAR;
dd2155a4 1983 I32 ix;
502c6561
NC
1984 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1985 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
53c1dcc0
AL
1986 SV ** const namepad = AvARRAY(comppad_name);
1987 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
1988
1989 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
1990 PERL_UNUSED_ARG(old_cv);
1991
dd2155a4 1992 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
551405c4 1993 const SV * const namesv = namepad[ix];
dd2155a4 1994 if (namesv && namesv != &PL_sv_undef
b15aece3 1995 && *SvPVX_const(namesv) == '&')
dd2155a4 1996 {
ea726b52 1997 CV * const innercv = MUTABLE_CV(curpad[ix]);
7dafbf52
DM
1998 assert(CvWEAKOUTSIDE(innercv));
1999 assert(CvOUTSIDE(innercv) == old_cv);
2000 CvOUTSIDE(innercv) = new_cv;
dd2155a4
DM
2001 }
2002 }
2003}
2004
2005/*
cc76b5cc 2006=for apidoc m|void|pad_push|PADLIST *padlist|int depth
dd2155a4
DM
2007
2008Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
2009this depth, in which case don't bother creating a new one. Then give
2010the new pad an @_ in slot zero.
dd2155a4
DM
2011
2012=cut
2013*/
2014
2015void
26019298 2016Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2017{
97aff369 2018 dVAR;
7918f24d
NC
2019
2020 PERL_ARGS_ASSERT_PAD_PUSH;
2021
b37c2d43 2022 if (depth > AvFILLp(padlist)) {
44f8325f
AL
2023 SV** const svp = AvARRAY(padlist);
2024 AV* const newpad = newAV();
2025 SV** const oldpad = AvARRAY(svp[depth-1]);
502c6561
NC
2026 I32 ix = AvFILLp((const AV *)svp[1]);
2027 const I32 names_fill = AvFILLp((const AV *)svp[0]);
44f8325f 2028 SV** const names = AvARRAY(svp[0]);
26019298
AL
2029 AV *av;
2030
dd2155a4
DM
2031 for ( ;ix > 0; ix--) {
2032 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
b15aece3 2033 const char sigil = SvPVX_const(names[ix])[0];
fda94784
RGS
2034 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2035 || (SvFLAGS(names[ix]) & SVpad_STATE)
2036 || sigil == '&')
2037 {
dd2155a4
DM
2038 /* outer lexical or anon code */
2039 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2040 }
2041 else { /* our own lexical */
26019298
AL
2042 SV *sv;
2043 if (sigil == '@')
ad64d0ec 2044 sv = MUTABLE_SV(newAV());
26019298 2045 else if (sigil == '%')
ad64d0ec 2046 sv = MUTABLE_SV(newHV());
dd2155a4 2047 else
561b68a9 2048 sv = newSV(0);
26019298 2049 av_store(newpad, ix, sv);
dd2155a4
DM
2050 SvPADMY_on(sv);
2051 }
2052 }
2053 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
f84c484e 2054 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2055 }
2056 else {
2057 /* save temporaries on recursion? */
561b68a9 2058 SV * const sv = newSV(0);
26019298 2059 av_store(newpad, ix, sv);
dd2155a4
DM
2060 SvPADTMP_on(sv);
2061 }
2062 }
26019298 2063 av = newAV();
ad64d0ec 2064 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2065 AvREIFY_only(av);
26019298 2066
ad64d0ec 2067 av_store(padlist, depth, MUTABLE_SV(newpad));
dd2155a4
DM
2068 AvFILLp(padlist) = depth;
2069 }
2070}
b21dc031 2071
cc76b5cc
Z
2072/*
2073=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2074
2075Looks up the type of the lexical variable at position I<po> in the
2076currently-compiling pad. If the variable is typed, the stash of the
2077class to which it is typed is returned. If not, C<NULL> is returned.
2078
2079=cut
2080*/
b21dc031
AL
2081
2082HV *
2083Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2084{
97aff369 2085 dVAR;
551405c4 2086 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
00b1698f 2087 if ( SvPAD_TYPED(*av) ) {
b21dc031
AL
2088 return SvSTASH(*av);
2089 }
5c284bb0 2090 return NULL;
b21dc031 2091}
66610fdd 2092
d5b1589c
NC
2093#if defined(USE_ITHREADS)
2094
2095# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2096
cc76b5cc
Z
2097/*
2098=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2099
2100Duplicates a pad.
2101
2102=cut
2103*/
2104
d5b1589c 2105AV *
cc76b5cc 2106Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
d5b1589c
NC
2107{
2108 AV *dstpad;
2109 PERL_ARGS_ASSERT_PADLIST_DUP;
2110
2111 if (!srcpad)
2112 return NULL;
2113
2114 assert(!AvREAL(srcpad));
6de654a5
NC
2115
2116 if (param->flags & CLONEf_COPY_STACKS
2117 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2118 /* XXX padlists are real, but pretend to be not */
2119 AvREAL_on(srcpad);
2120 dstpad = av_dup_inc(srcpad, param);
2121 AvREAL_off(srcpad);
2122 AvREAL_off(dstpad);
2123 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2124 } else {
2125 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2126 to build anything other than the first level of pads. */
2127
2128 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2129 AV *pad1;
05d04d9c 2130 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
6de654a5
NC
2131 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2132 SV **oldpad = AvARRAY(srcpad1);
2133 SV **names;
2134 SV **pad1a;
2135 AV *args;
2136 /* look for it in the table first.
2137 I *think* that it shouldn't be possible to find it there.
2138 Well, except for how Perl_sv_compile_2op() "works" :-( */
2139 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2140
2141 if (dstpad)
2142 return dstpad;
2143
2144 dstpad = newAV();
2145 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2146 AvREAL_off(dstpad);
2147 av_extend(dstpad, 1);
2148 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2149 names = AvARRAY(AvARRAY(dstpad)[0]);
2150
2151 pad1 = newAV();
2152
2153 av_extend(pad1, ix);
2154 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2155 pad1a = AvARRAY(pad1);
2156 AvFILLp(dstpad) = 1;
2157
2158 if (ix > -1) {
2159 AvFILLp(pad1) = ix;
2160
2161 for ( ;ix > 0; ix--) {
05d04d9c
NC
2162 if (!oldpad[ix]) {
2163 pad1a[ix] = NULL;
2164 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2165 const char sigil = SvPVX_const(names[ix])[0];
2166 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2167 || (SvFLAGS(names[ix]) & SVpad_STATE)
2168 || sigil == '&')
2169 {
2170 /* outer lexical or anon code */
2171 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2172 }
2173 else { /* our own lexical */
adf8f095
NC
2174 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2175 /* This is a work around for how the current
2176 implementation of ?{ } blocks in regexps
2177 interacts with lexicals. */
05d04d9c
NC
2178 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2179 } else {
2180 SV *sv;
2181
2182 if (sigil == '@')
2183 sv = MUTABLE_SV(newAV());
2184 else if (sigil == '%')
2185 sv = MUTABLE_SV(newHV());
2186 else
2187 sv = newSV(0);
2188 pad1a[ix] = sv;
2189 SvPADMY_on(sv);
2190 }
2191 }
2192 }
2193 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2194 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2195 }
2196 else {
2197 /* save temporaries on recursion? */
2198 SV * const sv = newSV(0);
2199 pad1a[ix] = sv;
2200
2201 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2202 FIXTHAT before merging this branch.
2203 (And I know how to) */
2204 if (SvPADMY(oldpad[ix]))
2205 SvPADMY_on(sv);
2206 else
2207 SvPADTMP_on(sv);
2208 }
6de654a5
NC
2209 }
2210
2211 if (oldpad[0]) {
2212 args = newAV(); /* Will be @_ */
2213 AvREIFY_only(args);
2214 pad1a[0] = (SV *)args;
2215 }
2216 }
2217 }
d5b1589c
NC
2218
2219 return dstpad;
2220}
2221
cc76b5cc 2222#endif /* USE_ITHREADS */
d5b1589c 2223
66610fdd
RGS
2224/*
2225 * Local variables:
2226 * c-indentation-style: bsd
2227 * c-basic-offset: 4
2228 * indent-tabs-mode: t
2229 * End:
2230 *
37442d52
RGS
2231 * ex: set ts=8 sts=4 sw=4 noet:
2232 */