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