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