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