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