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