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