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