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