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