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