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