This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
win32_msgwait() problem
[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 *
c7c737cb 114Perl_pad_new(pTHX_ int flags)
dd2155a4
DM
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
7e736055
HS
1123 /* SV could be a shared hash key (eg bugid #19022) */
1124 if (
dd2155a4 1125#ifdef PERL_COPY_ON_WRITE
7e736055
HS
1126 !SvIsCOW(PL_curpad[po])
1127#else
1128 !SvFAKE(PL_curpad[po])
dd2155a4 1129#endif
7e736055 1130 )
dd2155a4 1131 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
dd2155a4
DM
1132#endif
1133 }
1134 if ((I32)po < PL_padix)
1135 PL_padix = po - 1;
1136}
1137
1138
1139
1140/*
1141=for apidoc do_dump_pad
1142
1143Dump the contents of a padlist
1144
1145=cut
1146*/
1147
1148void
1149Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1150{
1151 AV *pad_name;
1152 AV *pad;
1153 SV **pname;
1154 SV **ppad;
1155 SV *namesv;
1156 I32 ix;
1157
1158 if (!padlist) {
1159 return;
1160 }
1161 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1162 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1163 pname = AvARRAY(pad_name);
1164 ppad = AvARRAY(pad);
1165 Perl_dump_indent(aTHX_ level, file,
1166 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1167 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1168 );
1169
1170 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1171 namesv = pname[ix];
1172 if (namesv && namesv == &PL_sv_undef) {
1173 namesv = Nullsv;
1174 }
1175 if (namesv) {
ee6cee0c
DM
1176 if (SvFAKE(namesv))
1177 Perl_dump_indent(aTHX_ level+1, file,
1178 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\"\n",
1179 (int) ix,
1180 PTR2UV(ppad[ix]),
1181 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1182 SvPVX(namesv)
1183 );
1184 else
1185 Perl_dump_indent(aTHX_ level+1, file,
1186 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1187 (int) ix,
1188 PTR2UV(ppad[ix]),
1189 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1190 (unsigned long)I_32(SvNVX(namesv)),
1191 (unsigned long)SvIVX(namesv),
1192 SvPVX(namesv)
1193 );
dd2155a4
DM
1194 }
1195 else if (full) {
1196 Perl_dump_indent(aTHX_ level+1, file,
1197 "%2d. 0x%"UVxf"<%lu>\n",
1198 (int) ix,
1199 PTR2UV(ppad[ix]),
1200 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1201 );
1202 }
1203 }
1204}
1205
1206
1207
1208/*
1209=for apidoc cv_dump
1210
1211dump the contents of a CV
1212
1213=cut
1214*/
1215
1216#ifdef DEBUGGING
1217STATIC void
1218S_cv_dump(pTHX_ CV *cv, char *title)
1219{
1220 CV *outside = CvOUTSIDE(cv);
1221 AV* padlist = CvPADLIST(cv);
1222
1223 PerlIO_printf(Perl_debug_log,
1224 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1225 title,
1226 PTR2UV(cv),
1227 (CvANON(cv) ? "ANON"
1228 : (cv == PL_main_cv) ? "MAIN"
1229 : CvUNIQUE(cv) ? "UNIQUE"
1230 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1231 PTR2UV(outside),
1232 (!outside ? "null"
1233 : CvANON(outside) ? "ANON"
1234 : (outside == PL_main_cv) ? "MAIN"
1235 : CvUNIQUE(outside) ? "UNIQUE"
1236 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1237
1238 PerlIO_printf(Perl_debug_log,
1239 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1240 do_dump_pad(1, Perl_debug_log, padlist, 1);
1241}
1242#endif /* DEBUGGING */
1243
1244
1245
1246
1247
1248/*
1249=for apidoc cv_clone
1250
1251Clone a CV: make a new CV which points to the same code etc, but which
1252has a newly-created pad built by copying the prototype pad and capturing
1253any outer lexicals.
1254
1255=cut
1256*/
1257
1258CV *
1259Perl_cv_clone(pTHX_ CV *proto)
1260{
1261 CV *cv;
1262
1263 LOCK_CRED_MUTEX; /* XXX create separate mutex */
1264 cv = cv_clone2(proto, CvOUTSIDE(proto));
1265 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
1266 return cv;
1267}
1268
1269
1270/* XXX DAPM separate out cv and paddish bits ???
1271 * ideally the CV-related stuff shouldn't be in pad.c - how about
1272 * a cv.c? */
1273
1274STATIC CV *
1275S_cv_clone2(pTHX_ CV *proto, CV *outside)
1276{
1277 I32 ix;
1278 AV* protopadlist = CvPADLIST(proto);
1279 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1280 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1281 SV** pname = AvARRAY(protopad_name);
1282 SV** ppad = AvARRAY(protopad);
1283 I32 fname = AvFILLp(protopad_name);
1284 I32 fpad = AvFILLp(protopad);
1285 AV* comppadlist;
1286 CV* cv;
1287
1288 assert(!CvUNIQUE(proto));
1289
1290 ENTER;
1291 SAVESPTR(PL_compcv);
1292
1293 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1294 sv_upgrade((SV *)cv, SvTYPE(proto));
7dafbf52 1295 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
dd2155a4
DM
1296 CvCLONED_on(cv);
1297
dd2155a4
DM
1298#ifdef USE_ITHREADS
1299 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1300 : savepv(CvFILE(proto));
1301#else
1302 CvFILE(cv) = CvFILE(proto);
1303#endif
1304 CvGV(cv) = CvGV(proto);
1305 CvSTASH(cv) = CvSTASH(proto);
1306 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1307 CvSTART(cv) = CvSTART(proto);
a3985cdc 1308 if (outside) {
dd2155a4 1309 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
a3985cdc
DM
1310 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1311 }
dd2155a4
DM
1312
1313 if (SvPOK(proto))
1314 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1315
1316 CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1317
1318 for (ix = fname; ix >= 0; ix--)
1319 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1320
1321 av_fill(PL_comppad, fpad);
1322 PL_curpad = AvARRAY(PL_comppad);
1323
1324 for (ix = fpad; ix > 0; ix--) {
1325 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1326 if (namesv && namesv != &PL_sv_undef) {
1327 char *name = SvPVX(namesv); /* XXX */
1328 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
a3985cdc 1329 I32 off = pad_findlex(name, ix, cv);
dd2155a4
DM
1330 if (!off)
1331 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1332 else if (off != ix)
1333 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1334 }
1335 else { /* our own lexical */
1336 SV* sv;
1337 if (*name == '&') {
1338 /* anon code -- we'll come back for it */
1339 sv = SvREFCNT_inc(ppad[ix]);
1340 }
1341 else if (*name == '@')
1342 sv = (SV*)newAV();
1343 else if (*name == '%')
1344 sv = (SV*)newHV();
1345 else
1346 sv = NEWSV(0, 0);
1347 if (!SvPADBUSY(sv))
1348 SvPADMY_on(sv);
1349 PL_curpad[ix] = sv;
1350 }
1351 }
1352 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1353 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1354 }
1355 else {
1356 SV* sv = NEWSV(0, 0);
1357 SvPADTMP_on(sv);
1358 PL_curpad[ix] = sv;
1359 }
1360 }
1361
1362 /* Now that vars are all in place, clone nested closures. */
1363
1364 for (ix = fpad; ix > 0; ix--) {
1365 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1366 if (namesv
1367 && namesv != &PL_sv_undef
1368 && !(SvFLAGS(namesv) & SVf_FAKE)
1369 && *SvPVX(namesv) == '&'
1370 && CvCLONE(ppad[ix]))
1371 {
1372 CV *kid = cv_clone2((CV*)ppad[ix], cv);
1373 SvREFCNT_dec(ppad[ix]);
1374 CvCLONE_on(kid);
1375 SvPADMY_on(kid);
1376 PL_curpad[ix] = (SV*)kid;
7dafbf52
DM
1377 /* '&' entry points to child, so child mustn't refcnt parent */
1378 CvWEAKOUTSIDE_on(kid);
1379 SvREFCNT_dec(cv);
dd2155a4
DM
1380 }
1381 }
1382
1383 DEBUG_Xv(
1384 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1385 cv_dump(outside, "Outside");
1386 cv_dump(proto, "Proto");
1387 cv_dump(cv, "To");
1388 );
1389
1390 LEAVE;
1391
1392 if (CvCONST(cv)) {
1393 SV* const_sv = op_const_sv(CvSTART(cv), cv);
1394 assert(const_sv);
1395 /* constant sub () { $x } closing over $x - see lib/constant.pm */
1396 SvREFCNT_dec(cv);
1397 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1398 }
1399
1400 return cv;
1401}
1402
1403
1404/*
1405=for apidoc pad_fixup_inner_anons
1406
1407For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
1408old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1409moved to a pre-existing CV struct.
dd2155a4
DM
1410
1411=cut
1412*/
1413
1414void
1415Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1416{
1417 I32 ix;
1418 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1419 AV *comppad = (AV*)AvARRAY(padlist)[1];
1420 SV **namepad = AvARRAY(comppad_name);
1421 SV **curpad = AvARRAY(comppad);
1422 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1423 SV *namesv = namepad[ix];
1424 if (namesv && namesv != &PL_sv_undef
1425 && *SvPVX(namesv) == '&')
1426 {
1427 CV *innercv = (CV*)curpad[ix];
7dafbf52
DM
1428 assert(CvWEAKOUTSIDE(innercv));
1429 assert(CvOUTSIDE(innercv) == old_cv);
1430 CvOUTSIDE(innercv) = new_cv;
dd2155a4
DM
1431 }
1432 }
1433}
1434
7dafbf52 1435
dd2155a4
DM
1436/*
1437=for apidoc pad_push
1438
1439Push a new pad frame onto the padlist, unless there's already a pad at
1440this depth, in which case don't bother creating a new one.
1441If has_args is true, give the new pad an @_ in slot zero.
1442
1443=cut
1444*/
1445
1446void
1447Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1448{
1449 if (depth <= AvFILLp(padlist))
1450 return;
1451
1452 {
1453 SV** svp = AvARRAY(padlist);
1454 AV *newpad = newAV();
1455 SV **oldpad = AvARRAY(svp[depth-1]);
1456 I32 ix = AvFILLp((AV*)svp[1]);
1457 I32 names_fill = AvFILLp((AV*)svp[0]);
1458 SV** names = AvARRAY(svp[0]);
1459 SV* sv;
1460 for ( ;ix > 0; ix--) {
1461 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1462 char *name = SvPVX(names[ix]);
1463 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1464 /* outer lexical or anon code */
1465 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1466 }
1467 else { /* our own lexical */
1468 if (*name == '@')
1469 av_store(newpad, ix, sv = (SV*)newAV());
1470 else if (*name == '%')
1471 av_store(newpad, ix, sv = (SV*)newHV());
1472 else
1473 av_store(newpad, ix, sv = NEWSV(0, 0));
1474 SvPADMY_on(sv);
1475 }
1476 }
1477 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1478 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1479 }
1480 else {
1481 /* save temporaries on recursion? */
1482 av_store(newpad, ix, sv = NEWSV(0, 0));
1483 SvPADTMP_on(sv);
1484 }
1485 }
1486 if (has_args) {
1487 AV* av = newAV();
1488 av_extend(av, 0);
1489 av_store(newpad, 0, (SV*)av);
1490 AvFLAGS(av) = AVf_REIFY;
1491 }
1492 av_store(padlist, depth, (SV*)newpad);
1493 AvFILLp(padlist) = depth;
1494 }
1495}