This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
move all pad-related code to its own src file
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
3 * Copyright (c) 2002, Larry Wall
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 * "Anyway: there was this Mr Frodo left an orphan and stranded, as you
9 * might say, among those queer Bucklanders, being brought up anyhow in
10 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
11 * never had fewer than a couple of hundred relations in the place. Mr
12 * Bilbo never did a kinder deed than when he brought the lad back to
13 * live among decent folk." --the Gaffer
14 */
15
16/* XXX DAPM
17 * As of Sept 2002, this file is new and may be in a state of flux for
18 * a while. I've marked things I intent to come back and look at further
19 * with an 'XXX DAPM' comment.
20 */
21
22/*
23=head1 Pad Data Structures
24
25=for apidoc m|AV *|CvPADLIST|CV *cv
26CV's can have CvPADLIST(cv) set to point to an AV.
27
28For these purposes "forms" are a kind-of CV, eval""s are too (except they're
29not callable at will and are always thrown away after the eval"" is done
30executing).
31
32XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
33but that is really the callers pad (a slot of which is allocated by
34every entersub).
35
36The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
37is managed "manual" (mostly in op.c) rather than normal av.c rules.
38The items in the AV are not SVs as for a normal AV, but other AVs:
39
400'th Entry of the CvPADLIST is an AV which represents the "names" or rather
41the "static type information" for lexicals.
42
43The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
44depth of recursion into the CV.
45The 0'th slot of a frame AV is an AV which is @_.
46other entries are storage for variables and op targets.
47
48During compilation:
49C<PL_comppad_name> is set the the the names AV.
50C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
51C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
52
53Itterating over the names AV itterates over all possible pad
54items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
55&PL_sv_undef "names" (see pad_alloc()).
56
57Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
58The rest are op targets/GVs/constants which are statically allocated
59or resolved at compile time. These don't have names by which they
60can be looked up from Perl code at run time through eval"" like
61my/our variables can be. Since they can't be looked up by "name"
62but only by their index allocated at compile time (which is usually
63in PL_op->op_targ), wasting a name SV for them doesn't make sense.
64
65The SVs in the names AV have their PV being the name of the variable.
66NV+1..IV inclusive is a range of cop_seq numbers for which the name is
67valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
68type. For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
69stash of the associated global (so that duplicate C<our> delarations in the
70same package can be detected). SvCUR is sometimes hijacked to
71store the generation number during compilation.
72
73If SvFAKE is set on the name SV then slot in the frame AVs are
74a REFCNT'ed references to a lexical from "outside".
75
76If the 'name' is '&' the the corresponding entry in frame AV
77is a CV representing a possible closure.
78(SvFAKE and name of '&' is not a meaningful combination currently but could
79become so if C<my sub foo {}> is implemented.)
80
81=cut
82*/
83
84
85#include "EXTERN.h"
86#define PERL_IN_PAD_C
87#include "perl.h"
88
89
90#define PAD_MAX 999999999
91
92
93
94/*
95=for apidoc pad_new
96
97Create a new compiling padlist, saving and updating the various global
98vars at the same time as creating the pad itself. The following flags
99can be OR'ed together:
100
101 padnew_CLONE this pad is for a cloned CV
102 padnew_SAVE save old globals
103 padnew_SAVESUB also save extra stuff for start of sub
104
105=cut
106*/
107
108PADLIST *
109Perl_pad_new(pTHX_ padnew_flags flags)
110{
111 AV *padlist, *padname, *pad, *a0;
112
113 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
114 * vars (based on flags) rather than storing vals + addresses for
115 * each individually. Also see pad_block_start.
116 * XXX DAPM Try to see whether all these conditionals are required
117 */
118
119 /* save existing state, ... */
120
121 if (flags & padnew_SAVE) {
122 SAVEVPTR(PL_curpad);
123 SAVESPTR(PL_comppad);
124 SAVESPTR(PL_comppad_name);
125 if (! (flags & padnew_CLONE)) {
126 SAVEI32(PL_padix);
127 SAVEI32(PL_comppad_name_fill);
128 SAVEI32(PL_min_intro_pending);
129 SAVEI32(PL_max_intro_pending);
130 if (flags & padnew_SAVESUB) {
131 SAVEI32(PL_pad_reset_pending);
132 }
133 }
134 }
135 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
136 * saved - check at some pt that this is okay */
137
138 /* ... create new pad ... */
139
140 padlist = newAV();
141 padname = newAV();
142 pad = newAV();
143
144 if (flags & padnew_CLONE) {
145 /* XXX DAPM I dont know why cv_clone needs it
146 * doing differently yet - perhaps this separate branch can be
147 * dispensed with eventually ???
148 */
149
150 a0 = newAV(); /* will be @_ */
151 av_extend(a0, 0);
152 av_store(pad, 0, (SV*)a0);
153 AvFLAGS(a0) = AVf_REIFY;
154 }
155 else {
156#ifdef USE_5005THREADS
157 av_store(padname, 0, newSVpvn("@_", 2));
158 a0 = newAV();
159 SvPADMY_on((SV*)a0); /* XXX Needed? */
160 av_store(pad, 0, (SV*)a0);
161#else
162 av_store(pad, 0, Nullsv);
163#endif /* USE_THREADS */
164 }
165
166 AvREAL_off(padlist);
167 av_store(padlist, 0, (SV*)padname);
168 av_store(padlist, 1, (SV*)pad);
169
170 /* ... then update state variables */
171
172 PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
173 PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
174 PL_curpad = AvARRAY(PL_comppad);
175
176 if (! (flags & padnew_CLONE)) {
177 PL_comppad_name_fill = 0;
178 PL_min_intro_pending = 0;
179 PL_padix = 0;
180 }
181
182 DEBUG_X(PerlIO_printf(Perl_debug_log,
183 "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
184 " name=0x%"UVxf" flags=0x%"UVxf"\n",
185 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
186 PTR2UV(padname), (UV)flags
187 )
188 );
189
190 return (PADLIST*)padlist;
191}
192
193/*
194=for apidoc pad_undef
195
196Free the padlist associated with a CV.
197If parts of it happen to be current, we null the relevant
198PL_*pad* global vars so that we don't have any dangling references left.
199We also repoint the CvOUTSIDE of any about-to-be-orphaned
200inner subs to outercv.
201
202=cut
203*/
204
205void
206Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
207{
208 I32 ix;
209 PADLIST *padlist = CvPADLIST(cv);
210
211 if (!padlist)
212 return;
213 if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
214 return;
215
216 DEBUG_X(PerlIO_printf(Perl_debug_log,
217 "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
218 );
219
220 /* pads may be cleared out already during global destruction */
221 if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
222 && !PL_dirty) || CvSPECIAL(cv))
223 {
224 /* XXX DAPM the following code is very similar to
225 * pad_fixup_inner_anons(). Merge??? */
226
227 /* inner references to eval's cv must be fixed up */
228 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
229 SV **namepad = AvARRAY(comppad_name);
230 AV *comppad = (AV*)AvARRAY(padlist)[1];
231 SV **curpad = AvARRAY(comppad);
232 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
233 SV *namesv = namepad[ix];
234 if (namesv && namesv != &PL_sv_undef
235 && *SvPVX(namesv) == '&'
236 && ix <= AvFILLp(comppad))
237 {
238 CV *innercv = (CV*)curpad[ix];
239 if (innercv && SvTYPE(innercv) == SVt_PVCV
240 && CvOUTSIDE(innercv) == cv)
241 {
242 CvOUTSIDE(innercv) = outercv;
243 if (!CvANON(innercv) || CvCLONED(innercv)) {
244 (void)SvREFCNT_inc(outercv);
245 if (SvREFCNT(cv))
246 SvREFCNT_dec(cv);
247 }
248 }
249 }
250 }
251 }
252 ix = AvFILLp(padlist);
253 while (ix >= 0) {
254 SV* sv = AvARRAY(padlist)[ix--];
255 if (!sv)
256 continue;
257 if (sv == (SV*)PL_comppad_name)
258 PL_comppad_name = Nullav;
259 else if (sv == (SV*)PL_comppad) {
260 PL_comppad = Nullav;
261 PL_curpad = Null(SV**);
262 }
263 SvREFCNT_dec(sv);
264 }
265 SvREFCNT_dec((SV*)CvPADLIST(cv));
266 CvPADLIST(cv) = Null(PADLIST*);
267}
268
269
270
271
272/*
273=for apidoc pad_add_name
274
275Create a new name in the current pad at the specified offset.
276If C<typestash> is valid, the name is for a typed lexical; set the
277name's stash to that value.
278If C<ourstash> is valid, it's an our lexical, set the name's
279GvSTASH to that value
280
281Also, if the name is @.. or %.., create a new array or hash for that slot
282
283If fake, it means we're cloning an existing entry
284
285=cut
286*/
287
288/*
289 * XXX DAPM this doesn't seem the right place to create a new array/hash.
290 * Whatever we do, we should be consistent - create scalars too, and
291 * create even if fake. Really need to integrate better the whole entry
292 * creation business - when + where does the name and value get created?
293 */
294
295PADOFFSET
296Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
297{
298 PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
299 SV* namesv = NEWSV(1102, 0);
300 U32 min, max;
301
302 if (fake) {
303 min = PL_curcop->cop_seq;
304 max = PAD_MAX;
305 }
306 else {
307 /* not yet introduced */
308 min = PAD_MAX;
309 max = 0;
310 }
311
312 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
313 "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
314 (long)offset, name, (unsigned long)min, (unsigned long)max,
315 (fake ? " FAKE" : "")
316 )
317 );
318
319 sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
320 sv_setpv(namesv, name);
321
322 if (typestash) {
323 SvFLAGS(namesv) |= SVpad_TYPED;
324 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
325 }
326 if (ourstash) {
327 SvFLAGS(namesv) |= SVpad_OUR;
328 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
329 }
330
331 av_store(PL_comppad_name, offset, namesv);
332 SvNVX(namesv) = (NV)min;
333 SvIVX(namesv) = max;
334 if (fake)
335 SvFAKE_on(namesv);
336 else {
337 if (!PL_min_intro_pending)
338 PL_min_intro_pending = offset;
339 PL_max_intro_pending = offset;
340 if (*name == '@')
341 av_store(PL_comppad, offset, (SV*)newAV());
342 else if (*name == '%')
343 av_store(PL_comppad, offset, (SV*)newHV());
344 SvPADMY_on(PL_curpad[offset]);
345 }
346
347 return offset;
348}
349
350
351
352
353/*
354=for apidoc pad_alloc
355
356Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
357the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
358for a slot which has no name and and no active value.
359
360=cut
361*/
362
363/* XXX DAPM integrate alloc(), add_name() and add_anon(),
364 * or at least rationalise ??? */
365
366
367PADOFFSET
368Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
369{
370 SV *sv;
371 I32 retval;
372
373 if (AvARRAY(PL_comppad) != PL_curpad)
374 Perl_croak(aTHX_ "panic: pad_alloc");
375 if (PL_pad_reset_pending)
376 pad_reset();
377 if (tmptype & SVs_PADMY) {
378 do {
379 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
380 } while (SvPADBUSY(sv)); /* need a fresh one */
381 retval = AvFILLp(PL_comppad);
382 }
383 else {
384 SV **names = AvARRAY(PL_comppad_name);
385 SSize_t names_fill = AvFILLp(PL_comppad_name);
386 for (;;) {
387 /*
388 * "foreach" index vars temporarily become aliases to non-"my"
389 * values. Thus we must skip, not just pad values that are
390 * marked as current pad values, but also those with names.
391 */
392 /* HVDS why copy to sv here? we don't seem to use it */
393 if (++PL_padix <= names_fill &&
394 (sv = names[PL_padix]) && sv != &PL_sv_undef)
395 continue;
396 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
397 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
398 !IS_PADGV(sv) && !IS_PADCONST(sv))
399 break;
400 }
401 retval = PL_padix;
402 }
403 SvFLAGS(sv) |= tmptype;
404 PL_curpad = AvARRAY(PL_comppad);
405
406 DEBUG_X(PerlIO_printf(Perl_debug_log,
407 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
408 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
409 PL_op_name[optype]));
410 return (PADOFFSET)retval;
411}
412
413/*
414=for apidoc pad_add_anon
415
416Add an anon code entry to the current compiling pad
417
418=cut
419*/
420
421PADOFFSET
422Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
423{
424 PADOFFSET ix;
425 SV* name;
426
427 name = NEWSV(1106, 0);
428 sv_upgrade(name, SVt_PVNV);
429 sv_setpvn(name, "&", 1);
430 SvIVX(name) = -1;
431 SvNVX(name) = 1;
432 ix = pad_alloc(op_type, SVs_PADMY);
433 av_store(PL_comppad_name, ix, name);
434 av_store(PL_comppad, ix, sv);
435 SvPADMY_on(sv);
436 return ix;
437}
438
439
440
441/*
442=for apidoc pad_check_dup
443
444Check for duplicate declarations: report any of:
445 * a my in the current scope with the same name;
446 * an our (anywhere in the pad) with the same name and the same stash
447 as C<ourstash>
448C<is_our> indicates that the name to check is an 'our' declaration
449
450=cut
451*/
452
453/* XXX DAPM integrate this into pad_add_name ??? */
454
455void
456Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
457{
458 SV **svp, *sv;
459 PADOFFSET top, off;
460
461 if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
462 return; /* nothing to check */
463
464 svp = AvARRAY(PL_comppad_name);
465 top = AvFILLp(PL_comppad_name);
466 /* check the current scope */
467 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
468 * type ? */
469 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
470 if ((sv = svp[off])
471 && sv != &PL_sv_undef
472 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
473 && (!is_our
474 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
475 && strEQ(name, SvPVX(sv)))
476 {
477 Perl_warner(aTHX_ packWARN(WARN_MISC),
478 "\"%s\" variable %s masks earlier declaration in same %s",
479 (is_our ? "our" : "my"),
480 name,
481 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
482 --off;
483 break;
484 }
485 }
486 /* check the rest of the pad */
487 if (is_our) {
488 do {
489 if ((sv = svp[off])
490 && sv != &PL_sv_undef
491 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
492 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
493 && strEQ(name, SvPVX(sv)))
494 {
495 Perl_warner(aTHX_ packWARN(WARN_MISC),
496 "\"our\" variable %s redeclared", name);
497 Perl_warner(aTHX_ packWARN(WARN_MISC),
498 "\t(Did you mean \"local\" instead of \"our\"?)\n");
499 break;
500 }
501 } while ( off-- > 0 );
502 }
503}
504
505
506
507/*
508=for apidoc pad_findmy
509
510Given a lexical name, try to find its offset, first in the current pad,
511or failing that, in the pads of any lexically enclosing subs (including
512the complications introduced by eval). If the name is found in an outer pad,
513then a fake entry is added to the current pad.
514Returns the offset in the current pad, or NOT_IN_PAD on failure.
515
516=cut
517*/
518
519PADOFFSET
520Perl_pad_findmy(pTHX_ char *name)
521{
522 I32 off;
523 I32 pendoff = 0;
524 SV *sv;
525 SV **svp = AvARRAY(PL_comppad_name);
526 U32 seq = PL_cop_seqmax;
527 PERL_CONTEXT *cx;
528 CV *outside;
529
530 DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
531
532#ifdef USE_5005THREADS
533 /*
534 * Special case to get lexical (and hence per-thread) @_.
535 * XXX I need to find out how to tell at parse-time whether use
536 * of @_ should refer to a lexical (from a sub) or defgv (global
537 * scope and maybe weird sub-ish things like formats). See
538 * startsub in perly.y. It's possible that @_ could be lexical
539 * (at least from subs) even in non-threaded perl.
540 */
541 if (strEQ(name, "@_"))
542 return 0; /* success. (NOT_IN_PAD indicates failure) */
543#endif /* USE_5005THREADS */
544
545 /* The one we're looking for is probably just before comppad_name_fill. */
546 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
547 if ((sv = svp[off]) &&
548 sv != &PL_sv_undef &&
549 (!SvIVX(sv) ||
550 (seq <= (U32)SvIVX(sv) &&
551 seq > (U32)I_32(SvNVX(sv)))) &&
552 strEQ(SvPVX(sv), name))
553 {
554 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
555 return (PADOFFSET)off;
556 pendoff = off; /* this pending def. will override import */
557 }
558 }
559
560 outside = CvOUTSIDE(PL_compcv);
561
562 /* Check if if we're compiling an eval'', and adjust seq to be the
563 * eval's seq number. This depends on eval'' having a non-null
564 * CvOUTSIDE() while it is being compiled. The eval'' itself is
565 * identified by CvEVAL being true and CvGV being null. */
566 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
567 cx = &cxstack[cxstack_ix];
568 if (CxREALEVAL(cx))
569 seq = cx->blk_oldcop->cop_seq;
570 }
571
572 /* See if it's in a nested scope */
573 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
574 if (!off) /* pad_findlex returns 0 for failure...*/
575 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
576
577 /* If there is a pending local definition, this new alias must die */
578 if (pendoff)
579 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
580 return off;
581}
582
583
584
585/*
586=for apidoc pad_findlex
587
588Find a named lexical anywhere in a chain of nested pads. Add fake entries
589in the inner pads if its found in an outer one.
590
591If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
592
593=cut
594*/
595
596#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
597
598STATIC PADOFFSET
599S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
600 I32 cx_ix, I32 saweval, U32 flags)
601{
602 CV *cv;
603 I32 off;
604 SV *sv;
605 register I32 i;
606 register PERL_CONTEXT *cx;
607
608 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
609 "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
610 " ix=%ld saweval=%d flags=%lu\n",
611 name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
612 (long)cx_ix, (int)saweval, (unsigned long)flags
613 )
614 );
615
616 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
617 AV *curlist = CvPADLIST(cv);
618 SV **svp = av_fetch(curlist, 0, FALSE);
619 AV *curname;
620
621 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
622 " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
623 );
624
625 if (!svp || *svp == &PL_sv_undef)
626 continue;
627 curname = (AV*)*svp;
628 svp = AvARRAY(curname);
629 for (off = AvFILLp(curname); off > 0; off--) {
630 I32 depth;
631 AV *oldpad;
632 SV *oldsv;
633
634 if ( ! (
635 (sv = svp[off]) &&
636 sv != &PL_sv_undef &&
637 seq <= (U32)SvIVX(sv) &&
638 seq > (U32)I_32(SvNVX(sv)) &&
639 strEQ(SvPVX(sv), name))
640 )
641 continue;
642
643 depth = CvDEPTH(cv);
644 if (!depth) {
645 if (newoff) {
646 if (SvFAKE(sv))
647 continue;
648 return 0; /* don't clone from inactive stack frame */
649 }
650 depth = 1;
651 }
652
653 oldpad = (AV*)AvARRAY(curlist)[depth];
654 oldsv = *av_fetch(oldpad, off, TRUE);
655
656 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
657 " matched: offset %ld"
658 " %s(%lu,%lu), sv=0x%"UVxf"\n",
659 (long)off,
660 SvFAKE(sv) ? "FAKE " : "",
661 (unsigned long)I_32(SvNVX(sv)),
662 (unsigned long)SvIVX(sv),
663 PTR2UV(oldsv)
664 )
665 );
666
667 if (!newoff) { /* Not a mere clone operation. */
668 newoff = pad_add_name(
669 SvPVX(sv),
670 (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
671 (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
672 1 /* fake */
673 );
674
675 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
676 /* "It's closures all the way down." */
677 CvCLONE_on(PL_compcv);
678 if (cv == startcv) {
679 if (CvANON(PL_compcv))
680 oldsv = Nullsv; /* no need to keep ref */
681 }
682 else {
683 CV *bcv;
684 for (bcv = startcv;
685 bcv && bcv != cv && !CvCLONE(bcv);
686 bcv = CvOUTSIDE(bcv))
687 {
688 if (CvANON(bcv)) {
689 /* install the missing pad entry in intervening
690 * nested subs and mark them cloneable. */
691 AV *ocomppad_name = PL_comppad_name;
692 AV *ocomppad = PL_comppad;
693 SV **ocurpad = PL_curpad;
694 AV *padlist = CvPADLIST(bcv);
695 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
696 PL_comppad = (AV*)AvARRAY(padlist)[1];
697 PL_curpad = AvARRAY(PL_comppad);
698 pad_add_name(
699 SvPVX(sv),
700 (SvFLAGS(sv) & SVpad_TYPED)
701 ? SvSTASH(sv) : Nullhv,
702 (SvFLAGS(sv) & SVpad_OUR)
703 ? GvSTASH(sv) : Nullhv,
704 1 /* fake */
705 );
706
707 PL_comppad_name = ocomppad_name;
708 PL_comppad = ocomppad;
709 PL_curpad = ocurpad;
710 CvCLONE_on(bcv);
711 }
712 else {
713 if (ckWARN(WARN_CLOSURE)
714 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
715 {
716 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
717 "Variable \"%s\" may be unavailable",
718 name);
719 }
720 break;
721 }
722 }
723 }
724 }
725 else if (!CvUNIQUE(PL_compcv)) {
726 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
727 && !(SvFLAGS(sv) & SVpad_OUR))
728 {
729 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
730 "Variable \"%s\" will not stay shared", name);
731 }
732 }
733 }
734 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
735 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
736 "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
737 (long)newoff, PTR2UV(oldsv)
738 )
739 );
740 return newoff;
741 }
742 }
743
744 if (flags & FINDLEX_NOSEARCH)
745 return 0;
746
747 /* Nothing in current lexical context--try eval's context, if any.
748 * This is necessary to let the perldb get at lexically scoped variables.
749 * XXX This will also probably interact badly with eval tree caching.
750 */
751
752 for (i = cx_ix; i >= 0; i--) {
753 cx = &cxstack[i];
754 switch (CxTYPE(cx)) {
755 default:
756 if (i == 0 && saweval) {
757 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
758 }
759 break;
760 case CXt_EVAL:
761 switch (cx->blk_eval.old_op_type) {
762 case OP_ENTEREVAL:
763 if (CxREALEVAL(cx)) {
764 PADOFFSET off;
765 saweval = i;
766 seq = cxstack[i].blk_oldcop->cop_seq;
767 startcv = cxstack[i].blk_eval.cv;
768 if (startcv && CvOUTSIDE(startcv)) {
769 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
770 i - 1, saweval, 0);
771 if (off) /* continue looking if not found here */
772 return off;
773 }
774 }
775 break;
776 case OP_DOFILE:
777 case OP_REQUIRE:
778 /* require/do must have their own scope */
779 return 0;
780 }
781 break;
782 case CXt_FORMAT:
783 case CXt_SUB:
784 if (!saweval)
785 return 0;
786 cv = cx->blk_sub.cv;
787 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
788 saweval = i; /* so we know where we were called from */
789 seq = cxstack[i].blk_oldcop->cop_seq;
790 continue;
791 }
792 return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
793 }
794 }
795
796 return 0;
797}
798
799
800/*
801=for apidoc pad_sv
802
803Get the value at offset po in the current pad.
804Use macro PAD_SV instead of calling this function directly.
805
806=cut
807*/
808
809
810SV *
811Perl_pad_sv(pTHX_ PADOFFSET po)
812{
813#ifdef DEBUGGING
814 /* for display purposes, try to guess the AV corresponding to
815 * Pl_curpad */
816 AV *cp = PL_comppad;
817 if (cp && AvARRAY(cp) != PL_curpad)
818 cp = Nullav;
819#endif
820
821#ifndef USE_5005THREADS
822 if (!po)
823 Perl_croak(aTHX_ "panic: pad_sv po");
824#endif
825 DEBUG_X(PerlIO_printf(Perl_debug_log,
826 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
827 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
828 );
829 return PL_curpad[po];
830}
831
832
833/*
834=for apidoc pad_setsv
835
836Set the entry at offset po in the current pad to sv.
837Use the macro PAD_SETSV() rather than calling this function directly.
838
839=cut
840*/
841
842#ifdef DEBUGGING
843void
844Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
845{
846 /* for display purposes, try to guess the AV corresponding to
847 * Pl_curpad */
848 AV *cp = PL_comppad;
849 if (cp && AvARRAY(cp) != PL_curpad)
850 cp = Nullav;
851
852 DEBUG_X(PerlIO_printf(Perl_debug_log,
853 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
854 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
855 );
856 PL_curpad[po] = sv;
857}
858#endif
859
860
861
862/*
863=for apidoc pad_block_start
864
865Update the pad compilation state variables on entry to a new block
866
867=cut
868*/
869
870/* XXX DAPM perhaps:
871 * - integrate this in general state-saving routine ???
872 * - combine with the state-saving going on in pad_new ???
873 * - introduce a new SAVE type that does all this in one go ?
874 */
875
876void
877Perl_pad_block_start(pTHX_ int full)
878{
879 SAVEI32(PL_comppad_name_floor);
880 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
881 if (full)
882 PL_comppad_name_fill = PL_comppad_name_floor;
883 if (PL_comppad_name_floor < 0)
884 PL_comppad_name_floor = 0;
885 SAVEI32(PL_min_intro_pending);
886 SAVEI32(PL_max_intro_pending);
887 PL_min_intro_pending = 0;
888 SAVEI32(PL_comppad_name_fill);
889 SAVEI32(PL_padix_floor);
890 PL_padix_floor = PL_padix;
891 PL_pad_reset_pending = FALSE;
892}
893
894
895/*
896=for apidoc intro_my
897
898"Introduce" my variables to visible status.
899
900=cut
901*/
902
903U32
904Perl_intro_my(pTHX)
905{
906 SV **svp;
907 SV *sv;
908 I32 i;
909
910 if (! PL_min_intro_pending)
911 return PL_cop_seqmax;
912
913 svp = AvARRAY(PL_comppad_name);
914 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
915 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
916 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
917 SvNVX(sv) = (NV)PL_cop_seqmax;
918 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
919 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
920 (long)i, SvPVX(sv),
921 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
922 );
923 }
924 }
925 PL_min_intro_pending = 0;
926 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
927 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
928 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
929
930 return PL_cop_seqmax++;
931}
932
933/*
934=for apidoc pad_leavemy
935
936Cleanup at end of scope during compilation: set the max seq number for
937lexicals in this scope and warn of any lexicals that never got introduced.
938
939=cut
940*/
941
942void
943Perl_pad_leavemy(pTHX)
944{
945 I32 off;
946 SV **svp = AvARRAY(PL_comppad_name);
947 SV *sv;
948
949 PL_pad_reset_pending = FALSE;
950
951 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
952 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
953 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
954 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
955 "%s never introduced", SvPVX(sv));
956 }
957 }
958 /* "Deintroduce" my variables that are leaving with this scope. */
959 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
960 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
961 SvIVX(sv) = PL_cop_seqmax;
962 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
963 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
964 (long)off, SvPVX(sv),
965 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
966 );
967 }
968 }
969 PL_cop_seqmax++;
970 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
971 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
972}
973
974
975/*
976=for apidoc pad_swipe
977
978Abandon the tmp in the current pad at offset po and replace with a
979new one.
980
981=cut
982*/
983
984void
985Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
986{
987 if (!PL_curpad)
988 return;
989 if (AvARRAY(PL_comppad) != PL_curpad)
990 Perl_croak(aTHX_ "panic: pad_swipe curpad");
991 if (!po)
992 Perl_croak(aTHX_ "panic: pad_swipe po");
993
994 DEBUG_X(PerlIO_printf(Perl_debug_log,
995 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
996 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
997
998 if (PL_curpad[po])
999 SvPADTMP_off(PL_curpad[po]);
1000 if (refadjust)
1001 SvREFCNT_dec(PL_curpad[po]);
1002
1003 PL_curpad[po] = NEWSV(1107,0);
1004 SvPADTMP_on(PL_curpad[po]);
1005 if ((I32)po < PL_padix)
1006 PL_padix = po - 1;
1007}
1008
1009
1010/*
1011=for apidoc pad_reset
1012
1013Mark all the current temporaries for reuse
1014
1015=cut
1016*/
1017
1018/* XXX pad_reset() is currently disabled because it results in serious bugs.
1019 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1020 * on the stack by OPs that use them, there are several ways to get an alias
1021 * to a shared TARG. Such an alias will change randomly and unpredictably.
1022 * We avoid doing this until we can think of a Better Way.
1023 * GSAR 97-10-29 */
1024void
1025Perl_pad_reset(pTHX)
1026{
1027#ifdef USE_BROKEN_PAD_RESET
1028 register I32 po;
1029
1030 if (AvARRAY(PL_comppad) != PL_curpad)
1031 Perl_croak(aTHX_ "panic: pad_reset curpad");
1032
1033 DEBUG_X(PerlIO_printf(Perl_debug_log,
1034 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1035 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1036 (long)PL_padix, (long)PL_padix_floor
1037 )
1038 );
1039
1040 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1041 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1042 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1043 SvPADTMP_off(PL_curpad[po]);
1044 }
1045 PL_padix = PL_padix_floor;
1046 }
1047#endif
1048 PL_pad_reset_pending = FALSE;
1049}
1050
1051
1052/*
1053=for apidoc pad_tidy
1054
1055Tidy up a pad after we've finished compiling it:
1056 * remove most stuff from the pads of anonsub prototypes;
1057 * give it a @_;
1058 * mark tmps as such.
1059
1060=cut
1061*/
1062
1063/* XXX DAPM surely most of this stuff should be done properly
1064 * at the right time beforehand, rather than going around afterwards
1065 * cleaning up our mistakes ???
1066 */
1067
1068void
1069Perl_pad_tidy(pTHX_ padtidy_type type)
1070{
1071 PADOFFSET ix;
1072
1073 /* extend curpad to match namepad */
1074 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1075 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1076
1077 if (type == padtidy_SUBCLONE) {
1078 SV **namep = AvARRAY(PL_comppad_name);
1079 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1080 SV *namesv;
1081
1082 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1083 continue;
1084 /*
1085 * The only things that a clonable function needs in its
1086 * pad are references to outer lexicals and anonymous subs.
1087 * The rest are created anew during cloning.
1088 */
1089 if (!((namesv = namep[ix]) != Nullsv &&
1090 namesv != &PL_sv_undef &&
1091 (SvFAKE(namesv) ||
1092 *SvPVX(namesv) == '&')))
1093 {
1094 SvREFCNT_dec(PL_curpad[ix]);
1095 PL_curpad[ix] = Nullsv;
1096 }
1097 }
1098 }
1099 else if (type == padtidy_SUB) {
1100 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1101 AV *av = newAV(); /* Will be @_ */
1102 av_extend(av, 0);
1103 av_store(PL_comppad, 0, (SV*)av);
1104 AvFLAGS(av) = AVf_REIFY;
1105 }
1106
1107 /* XXX DAPM rationalise these two similar branches */
1108
1109 if (type == padtidy_SUB) {
1110 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1111 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1112 continue;
1113 if (!SvPADMY(PL_curpad[ix]))
1114 SvPADTMP_on(PL_curpad[ix]);
1115 }
1116 }
1117 else if (type == padtidy_FORMAT) {
1118 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1119 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1120 SvPADTMP_on(PL_curpad[ix]);
1121 }
1122 }
1123}
1124
1125
1126/*
1127=for apidoc pad_free
1128
1129Free the SV at offet po in the current pad.
1130
1131=cut
1132*/
1133
1134/* XXX DAPM integrate with pad_swipe ???? */
1135void
1136Perl_pad_free(pTHX_ PADOFFSET po)
1137{
1138 if (!PL_curpad)
1139 return;
1140 if (AvARRAY(PL_comppad) != PL_curpad)
1141 Perl_croak(aTHX_ "panic: pad_free curpad");
1142 if (!po)
1143 Perl_croak(aTHX_ "panic: pad_free po");
1144
1145 DEBUG_X(PerlIO_printf(Perl_debug_log,
1146 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1147 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1148 );
1149
1150 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1151 SvPADTMP_off(PL_curpad[po]);
1152#ifdef USE_ITHREADS
1153#ifdef PERL_COPY_ON_WRITE
1154 if (SvIsCOW(PL_curpad[po])) {
1155 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1156 } else
1157#endif
1158 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1159
1160#endif
1161 }
1162 if ((I32)po < PL_padix)
1163 PL_padix = po - 1;
1164}
1165
1166
1167
1168/*
1169=for apidoc do_dump_pad
1170
1171Dump the contents of a padlist
1172
1173=cut
1174*/
1175
1176void
1177Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1178{
1179 AV *pad_name;
1180 AV *pad;
1181 SV **pname;
1182 SV **ppad;
1183 SV *namesv;
1184 I32 ix;
1185
1186 if (!padlist) {
1187 return;
1188 }
1189 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1190 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1191 pname = AvARRAY(pad_name);
1192 ppad = AvARRAY(pad);
1193 Perl_dump_indent(aTHX_ level, file,
1194 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1195 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1196 );
1197
1198 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1199 namesv = pname[ix];
1200 if (namesv && namesv == &PL_sv_undef) {
1201 namesv = Nullsv;
1202 }
1203 if (namesv) {
1204 Perl_dump_indent(aTHX_ level+1, file,
1205 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1206 (int) ix,
1207 PTR2UV(ppad[ix]),
1208 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1209 SvFAKE(namesv) ? "FAKE" : " ",
1210 (unsigned long)I_32(SvNVX(namesv)),
1211 (unsigned long)SvIVX(namesv),
1212 SvPVX(namesv)
1213 );
1214 }
1215 else if (full) {
1216 Perl_dump_indent(aTHX_ level+1, file,
1217 "%2d. 0x%"UVxf"<%lu>\n",
1218 (int) ix,
1219 PTR2UV(ppad[ix]),
1220 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1221 );
1222 }
1223 }
1224}
1225
1226
1227
1228/*
1229=for apidoc cv_dump
1230
1231dump the contents of a CV
1232
1233=cut
1234*/
1235
1236#ifdef DEBUGGING
1237STATIC void
1238S_cv_dump(pTHX_ CV *cv, char *title)
1239{
1240 CV *outside = CvOUTSIDE(cv);
1241 AV* padlist = CvPADLIST(cv);
1242
1243 PerlIO_printf(Perl_debug_log,
1244 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1245 title,
1246 PTR2UV(cv),
1247 (CvANON(cv) ? "ANON"
1248 : (cv == PL_main_cv) ? "MAIN"
1249 : CvUNIQUE(cv) ? "UNIQUE"
1250 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1251 PTR2UV(outside),
1252 (!outside ? "null"
1253 : CvANON(outside) ? "ANON"
1254 : (outside == PL_main_cv) ? "MAIN"
1255 : CvUNIQUE(outside) ? "UNIQUE"
1256 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1257
1258 PerlIO_printf(Perl_debug_log,
1259 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1260 do_dump_pad(1, Perl_debug_log, padlist, 1);
1261}
1262#endif /* DEBUGGING */
1263
1264
1265
1266
1267
1268/*
1269=for apidoc cv_clone
1270
1271Clone a CV: make a new CV which points to the same code etc, but which
1272has a newly-created pad built by copying the prototype pad and capturing
1273any outer lexicals.
1274
1275=cut
1276*/
1277
1278CV *
1279Perl_cv_clone(pTHX_ CV *proto)
1280{
1281 CV *cv;
1282
1283 LOCK_CRED_MUTEX; /* XXX create separate mutex */
1284 cv = cv_clone2(proto, CvOUTSIDE(proto));
1285 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
1286 return cv;
1287}
1288
1289
1290/* XXX DAPM separate out cv and paddish bits ???
1291 * ideally the CV-related stuff shouldn't be in pad.c - how about
1292 * a cv.c? */
1293
1294STATIC CV *
1295S_cv_clone2(pTHX_ CV *proto, CV *outside)
1296{
1297 I32 ix;
1298 AV* protopadlist = CvPADLIST(proto);
1299 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1300 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1301 SV** pname = AvARRAY(protopad_name);
1302 SV** ppad = AvARRAY(protopad);
1303 I32 fname = AvFILLp(protopad_name);
1304 I32 fpad = AvFILLp(protopad);
1305 AV* comppadlist;
1306 CV* cv;
1307
1308 assert(!CvUNIQUE(proto));
1309
1310 ENTER;
1311 SAVESPTR(PL_compcv);
1312
1313 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1314 sv_upgrade((SV *)cv, SvTYPE(proto));
1315 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1316 CvCLONED_on(cv);
1317
1318#ifdef USE_5005THREADS
1319 New(666, CvMUTEXP(cv), 1, perl_mutex);
1320 MUTEX_INIT(CvMUTEXP(cv));
1321 CvOWNER(cv) = 0;
1322#endif /* USE_5005THREADS */
1323#ifdef USE_ITHREADS
1324 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1325 : savepv(CvFILE(proto));
1326#else
1327 CvFILE(cv) = CvFILE(proto);
1328#endif
1329 CvGV(cv) = CvGV(proto);
1330 CvSTASH(cv) = CvSTASH(proto);
1331 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1332 CvSTART(cv) = CvSTART(proto);
1333 if (outside)
1334 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1335
1336 if (SvPOK(proto))
1337 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1338
1339 CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1340
1341 for (ix = fname; ix >= 0; ix--)
1342 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1343
1344 av_fill(PL_comppad, fpad);
1345 PL_curpad = AvARRAY(PL_comppad);
1346
1347 for (ix = fpad; ix > 0; ix--) {
1348 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1349 if (namesv && namesv != &PL_sv_undef) {
1350 char *name = SvPVX(namesv); /* XXX */
1351 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
1352 I32 off = pad_findlex(name, ix, SvIVX(namesv),
1353 CvOUTSIDE(cv), cxstack_ix, 0, 0);
1354 if (!off)
1355 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1356 else if (off != ix)
1357 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1358 }
1359 else { /* our own lexical */
1360 SV* sv;
1361 if (*name == '&') {
1362 /* anon code -- we'll come back for it */
1363 sv = SvREFCNT_inc(ppad[ix]);
1364 }
1365 else if (*name == '@')
1366 sv = (SV*)newAV();
1367 else if (*name == '%')
1368 sv = (SV*)newHV();
1369 else
1370 sv = NEWSV(0, 0);
1371 if (!SvPADBUSY(sv))
1372 SvPADMY_on(sv);
1373 PL_curpad[ix] = sv;
1374 }
1375 }
1376 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1377 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1378 }
1379 else {
1380 SV* sv = NEWSV(0, 0);
1381 SvPADTMP_on(sv);
1382 PL_curpad[ix] = sv;
1383 }
1384 }
1385
1386 /* Now that vars are all in place, clone nested closures. */
1387
1388 for (ix = fpad; ix > 0; ix--) {
1389 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1390 if (namesv
1391 && namesv != &PL_sv_undef
1392 && !(SvFLAGS(namesv) & SVf_FAKE)
1393 && *SvPVX(namesv) == '&'
1394 && CvCLONE(ppad[ix]))
1395 {
1396 CV *kid = cv_clone2((CV*)ppad[ix], cv);
1397 SvREFCNT_dec(ppad[ix]);
1398 CvCLONE_on(kid);
1399 SvPADMY_on(kid);
1400 PL_curpad[ix] = (SV*)kid;
1401 }
1402 }
1403
1404 DEBUG_Xv(
1405 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1406 cv_dump(outside, "Outside");
1407 cv_dump(proto, "Proto");
1408 cv_dump(cv, "To");
1409 );
1410
1411 LEAVE;
1412
1413 if (CvCONST(cv)) {
1414 SV* const_sv = op_const_sv(CvSTART(cv), cv);
1415 assert(const_sv);
1416 /* constant sub () { $x } closing over $x - see lib/constant.pm */
1417 SvREFCNT_dec(cv);
1418 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1419 }
1420
1421 return cv;
1422}
1423
1424
1425/*
1426=for apidoc pad_fixup_inner_anons
1427
1428For any anon CVs in the pad, change CvOUTSIDE of that CV from
1429old_cv to new_cv if necessary.
1430
1431=cut
1432*/
1433
1434void
1435Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1436{
1437 I32 ix;
1438 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1439 AV *comppad = (AV*)AvARRAY(padlist)[1];
1440 SV **namepad = AvARRAY(comppad_name);
1441 SV **curpad = AvARRAY(comppad);
1442 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1443 SV *namesv = namepad[ix];
1444 if (namesv && namesv != &PL_sv_undef
1445 && *SvPVX(namesv) == '&')
1446 {
1447 CV *innercv = (CV*)curpad[ix];
1448 if (CvOUTSIDE(innercv) == old_cv) {
1449 CvOUTSIDE(innercv) = new_cv;
1450 if (!CvANON(innercv) || CvCLONED(innercv)) {
1451 (void)SvREFCNT_inc(new_cv);
1452 SvREFCNT_dec(old_cv);
1453 }
1454 }
1455 }
1456 }
1457}
1458
1459/*
1460=for apidoc pad_push
1461
1462Push a new pad frame onto the padlist, unless there's already a pad at
1463this depth, in which case don't bother creating a new one.
1464If has_args is true, give the new pad an @_ in slot zero.
1465
1466=cut
1467*/
1468
1469void
1470Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1471{
1472 if (depth <= AvFILLp(padlist))
1473 return;
1474
1475 {
1476 SV** svp = AvARRAY(padlist);
1477 AV *newpad = newAV();
1478 SV **oldpad = AvARRAY(svp[depth-1]);
1479 I32 ix = AvFILLp((AV*)svp[1]);
1480 I32 names_fill = AvFILLp((AV*)svp[0]);
1481 SV** names = AvARRAY(svp[0]);
1482 SV* sv;
1483 for ( ;ix > 0; ix--) {
1484 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1485 char *name = SvPVX(names[ix]);
1486 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1487 /* outer lexical or anon code */
1488 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1489 }
1490 else { /* our own lexical */
1491 if (*name == '@')
1492 av_store(newpad, ix, sv = (SV*)newAV());
1493 else if (*name == '%')
1494 av_store(newpad, ix, sv = (SV*)newHV());
1495 else
1496 av_store(newpad, ix, sv = NEWSV(0, 0));
1497 SvPADMY_on(sv);
1498 }
1499 }
1500 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1501 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1502 }
1503 else {
1504 /* save temporaries on recursion? */
1505 av_store(newpad, ix, sv = NEWSV(0, 0));
1506 SvPADTMP_on(sv);
1507 }
1508 }
1509 if (has_args) {
1510 AV* av = newAV();
1511 av_extend(av, 0);
1512 av_store(newpad, 0, (SV*)av);
1513 AvFLAGS(av) = AVf_REIFY;
1514 }
1515 av_store(padlist, depth, (SV*)newpad);
1516 AvFILLp(padlist) = depth;
1517 }
1518}