This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Same fix, for the test, now.
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
1d325971 3 * Copyright (C) 2002, 2003, 2004, 2005 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 134{
e1ec3a88 135 AV *padlist, *padname, *pad;
dd2155a4 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
e1ec3a88 176 AV * const a0 = newAV(); /* will be @_ */
dd2155a4
DM
177 av_extend(a0, 0);
178 av_store(pad, 0, (SV*)a0);
11ca45c0 179 AvREIFY_only(a0);
dd2155a4
DM
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;
e1ec3a88 232 const PADLIST *padlist = CvPADLIST(cv);
dd2155a4
DM
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);
e1ec3a88 252 const 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--) {
504618e9 258 SV * const namesv = namepad[ix];
dd2155a4 259 if (namesv && namesv != &PL_sv_undef
b15aece3 260 && *SvPVX_const(namesv) == '&')
dd2155a4 261 {
7fc63493 262 CV * const innercv = (CV*)curpad[ix];
10dc53a8
DM
263 U32 inner_rc = SvREFCNT(innercv);
264 assert(inner_rc);
7dafbf52
DM
265 namepad[ix] = Nullsv;
266 SvREFCNT_dec(namesv);
01773faa
DM
267
268 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
269 curpad[ix] = Nullsv;
270 SvREFCNT_dec(innercv);
10dc53a8 271 inner_rc--;
01773faa 272 }
10dc53a8 273 if (inner_rc /* in use, not just a prototype */
dd2155a4
DM
274 && CvOUTSIDE(innercv) == cv)
275 {
7dafbf52 276 assert(CvWEAKOUTSIDE(innercv));
9d1ce744
JH
277 /* don't relink to grandfather if he's being freed */
278 if (outercv && SvREFCNT(outercv)) {
279 CvWEAKOUTSIDE_off(innercv);
280 CvOUTSIDE(innercv) = outercv;
281 CvOUTSIDE_SEQ(innercv) = seq;
7fc63493 282 (void)SvREFCNT_inc(outercv);
9d1ce744
JH
283 }
284 else {
285 CvOUTSIDE(innercv) = Nullcv;
286 }
287
dd2155a4 288 }
9d1ce744 289
dd2155a4
DM
290 }
291 }
292 }
7dafbf52 293
dd2155a4
DM
294 ix = AvFILLp(padlist);
295 while (ix >= 0) {
296 SV* sv = AvARRAY(padlist)[ix--];
297 if (!sv)
298 continue;
299 if (sv == (SV*)PL_comppad_name)
300 PL_comppad_name = Nullav;
301 else if (sv == (SV*)PL_comppad) {
f3548bdc 302 PL_comppad = Null(PAD*);
dd2155a4
DM
303 PL_curpad = Null(SV**);
304 }
305 SvREFCNT_dec(sv);
306 }
307 SvREFCNT_dec((SV*)CvPADLIST(cv));
308 CvPADLIST(cv) = Null(PADLIST*);
309}
310
311
312
313
314/*
315=for apidoc pad_add_name
316
b5c19bd7
DM
317Create a new name and associated PADMY SV in the current pad; return the
318offset.
dd2155a4
DM
319If C<typestash> is valid, the name is for a typed lexical; set the
320name's stash to that value.
321If C<ourstash> is valid, it's an our lexical, set the name's
322GvSTASH to that value
323
dd2155a4
DM
324If fake, it means we're cloning an existing entry
325
326=cut
327*/
328
dd2155a4 329PADOFFSET
e1ec3a88 330Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake)
dd2155a4 331{
504618e9 332 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
dd2155a4 333 SV* namesv = NEWSV(1102, 0);
dd2155a4 334
f3548bdc
DM
335 ASSERT_CURPAD_ACTIVE("pad_add_name");
336
dd2155a4 337
dd2155a4
DM
338 sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
339 sv_setpv(namesv, name);
340
341 if (typestash) {
342 SvFLAGS(namesv) |= SVpad_TYPED;
b162af07 343 SvSTASH_set(namesv, (HV*)SvREFCNT_inc((SV*) typestash));
dd2155a4
DM
344 }
345 if (ourstash) {
346 SvFLAGS(namesv) |= SVpad_OUR;
347 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
348 }
349
350 av_store(PL_comppad_name, offset, namesv);
b5c19bd7 351 if (fake) {
dd2155a4 352 SvFAKE_on(namesv);
b5c19bd7
DM
353 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
354 "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
355 }
dd2155a4 356 else {
ee6cee0c 357 /* not yet introduced */
9d6ce603 358 SvNV_set(namesv, (NV)PAD_MAX); /* min */
b19bbeda 359 SvIV_set(namesv, 0); /* max */
ee6cee0c 360
dd2155a4
DM
361 if (!PL_min_intro_pending)
362 PL_min_intro_pending = offset;
363 PL_max_intro_pending = offset;
b5c19bd7 364 /* if it's not a simple scalar, replace with an AV or HV */
f3548bdc
DM
365 /* XXX DAPM since slot has been allocated, replace
366 * av_store with PL_curpad[offset] ? */
dd2155a4
DM
367 if (*name == '@')
368 av_store(PL_comppad, offset, (SV*)newAV());
369 else if (*name == '%')
370 av_store(PL_comppad, offset, (SV*)newHV());
371 SvPADMY_on(PL_curpad[offset]);
b5c19bd7
DM
372 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
373 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
374 (long)offset, name, PTR2UV(PL_curpad[offset])));
dd2155a4
DM
375 }
376
377 return offset;
378}
379
380
381
382
383/*
384=for apidoc pad_alloc
385
386Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
387the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
388for a slot which has no name and and no active value.
389
390=cut
391*/
392
393/* XXX DAPM integrate alloc(), add_name() and add_anon(),
394 * or at least rationalise ??? */
395
396
397PADOFFSET
398Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
399{
400 SV *sv;
401 I32 retval;
402
f3548bdc
DM
403 ASSERT_CURPAD_ACTIVE("pad_alloc");
404
dd2155a4
DM
405 if (AvARRAY(PL_comppad) != PL_curpad)
406 Perl_croak(aTHX_ "panic: pad_alloc");
407 if (PL_pad_reset_pending)
408 pad_reset();
409 if (tmptype & SVs_PADMY) {
235cc2e3 410 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
dd2155a4
DM
411 retval = AvFILLp(PL_comppad);
412 }
413 else {
414 SV **names = AvARRAY(PL_comppad_name);
e1ec3a88 415 const SSize_t names_fill = AvFILLp(PL_comppad_name);
dd2155a4
DM
416 for (;;) {
417 /*
418 * "foreach" index vars temporarily become aliases to non-"my"
419 * values. Thus we must skip, not just pad values that are
420 * marked as current pad values, but also those with names.
421 */
422 /* HVDS why copy to sv here? we don't seem to use it */
423 if (++PL_padix <= names_fill &&
424 (sv = names[PL_padix]) && sv != &PL_sv_undef)
425 continue;
426 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
427 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
428 !IS_PADGV(sv) && !IS_PADCONST(sv))
429 break;
430 }
431 retval = PL_padix;
432 }
433 SvFLAGS(sv) |= tmptype;
434 PL_curpad = AvARRAY(PL_comppad);
435
436 DEBUG_X(PerlIO_printf(Perl_debug_log,
437 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
438 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
439 PL_op_name[optype]));
fd0854ff
DM
440#ifdef DEBUG_LEAKING_SCALARS
441 sv->sv_debug_optype = optype;
442 sv->sv_debug_inpad = 1;
fd0854ff 443#endif
a212c8b5 444 return (PADOFFSET)retval;
dd2155a4
DM
445}
446
447/*
448=for apidoc pad_add_anon
449
450Add an anon code entry to the current compiling pad
451
452=cut
453*/
454
455PADOFFSET
456Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
457{
458 PADOFFSET ix;
459 SV* name;
460
461 name = NEWSV(1106, 0);
462 sv_upgrade(name, SVt_PVNV);
463 sv_setpvn(name, "&", 1);
b19bbeda 464 SvIV_set(name, -1);
9d6ce603 465 SvNV_set(name, 1);
dd2155a4
DM
466 ix = pad_alloc(op_type, SVs_PADMY);
467 av_store(PL_comppad_name, ix, name);
f3548bdc 468 /* XXX DAPM use PL_curpad[] ? */
dd2155a4
DM
469 av_store(PL_comppad, ix, sv);
470 SvPADMY_on(sv);
7dafbf52
DM
471
472 /* to avoid ref loops, we never have parent + child referencing each
473 * other simultaneously */
474 if (CvOUTSIDE((CV*)sv)) {
475 assert(!CvWEAKOUTSIDE((CV*)sv));
476 CvWEAKOUTSIDE_on((CV*)sv);
477 SvREFCNT_dec(CvOUTSIDE((CV*)sv));
478 }
dd2155a4
DM
479 return ix;
480}
481
482
483
484/*
485=for apidoc pad_check_dup
486
487Check for duplicate declarations: report any of:
488 * a my in the current scope with the same name;
489 * an our (anywhere in the pad) with the same name and the same stash
490 as C<ourstash>
491C<is_our> indicates that the name to check is an 'our' declaration
492
493=cut
494*/
495
496/* XXX DAPM integrate this into pad_add_name ??? */
497
498void
e1ec3a88 499Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
dd2155a4
DM
500{
501 SV **svp, *sv;
502 PADOFFSET top, off;
503
f3548bdc 504 ASSERT_CURPAD_ACTIVE("pad_check_dup");
dd2155a4
DM
505 if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
506 return; /* nothing to check */
507
508 svp = AvARRAY(PL_comppad_name);
509 top = AvFILLp(PL_comppad_name);
510 /* check the current scope */
511 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
512 * type ? */
513 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
514 if ((sv = svp[off])
515 && sv != &PL_sv_undef
ee6cee0c 516 && !SvFAKE(sv)
dd2155a4
DM
517 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
518 && (!is_our
519 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
b15aece3 520 && strEQ(name, SvPVX_const(sv)))
dd2155a4
DM
521 {
522 Perl_warner(aTHX_ packWARN(WARN_MISC),
523 "\"%s\" variable %s masks earlier declaration in same %s",
524 (is_our ? "our" : "my"),
525 name,
526 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
527 --off;
528 break;
529 }
530 }
531 /* check the rest of the pad */
532 if (is_our) {
533 do {
534 if ((sv = svp[off])
535 && sv != &PL_sv_undef
ee6cee0c 536 && !SvFAKE(sv)
dd2155a4
DM
537 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
538 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
b15aece3 539 && strEQ(name, SvPVX_const(sv)))
dd2155a4
DM
540 {
541 Perl_warner(aTHX_ packWARN(WARN_MISC),
542 "\"our\" variable %s redeclared", name);
543 Perl_warner(aTHX_ packWARN(WARN_MISC),
544 "\t(Did you mean \"local\" instead of \"our\"?)\n");
545 break;
546 }
547 } while ( off-- > 0 );
548 }
549}
550
551
dd2155a4
DM
552/*
553=for apidoc pad_findmy
554
555Given a lexical name, try to find its offset, first in the current pad,
556or failing that, in the pads of any lexically enclosing subs (including
557the complications introduced by eval). If the name is found in an outer pad,
558then a fake entry is added to the current pad.
559Returns the offset in the current pad, or NOT_IN_PAD on failure.
560
561=cut
562*/
563
564PADOFFSET
e1ec3a88 565Perl_pad_findmy(pTHX_ const char *name)
dd2155a4 566{
b5c19bd7
DM
567 SV *out_sv;
568 int out_flags;
929a0744 569 I32 offset;
e1ec3a88 570 const AV *nameav;
929a0744 571 SV **name_svp;
dd2155a4 572
929a0744 573 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
b5c19bd7 574 Null(SV**), &out_sv, &out_flags);
929a0744
DM
575 if (offset != NOT_IN_PAD)
576 return offset;
577
578 /* look for an our that's being introduced; this allows
579 * our $foo = 0 unless defined $foo;
580 * to not give a warning. (Yes, this is a hack) */
581
582 nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
583 name_svp = AvARRAY(nameav);
584 for (offset = AvFILLp(nameav); offset > 0; offset--) {
e1ec3a88 585 const SV *namesv = name_svp[offset];
929a0744
DM
586 if (namesv && namesv != &PL_sv_undef
587 && !SvFAKE(namesv)
588 && (SvFLAGS(namesv) & SVpad_OUR)
b15aece3 589 && strEQ(SvPVX_const(namesv), name)
4cf4a199 590 && U_32(SvNVX(namesv)) == PAD_MAX /* min */
929a0744
DM
591 )
592 return offset;
593 }
594 return NOT_IN_PAD;
dd2155a4
DM
595}
596
e1f795dc
RGS
597/*
598 * Returns the offset of a lexical $_, if there is one, at run time.
599 * Used by the UNDERBAR XS macro.
600 */
601
602PADOFFSET
29289021 603Perl_find_rundefsvoffset(pTHX)
e1f795dc
RGS
604{
605 SV *out_sv;
606 int out_flags;
607 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
608 Null(SV**), &out_sv, &out_flags);
609}
dd2155a4 610
dd2155a4
DM
611/*
612=for apidoc pad_findlex
613
614Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
615in the inner pads if it's found in an outer one.
616
617Returns the offset in the bottom pad of the lex or the fake lex.
618cv is the CV in which to start the search, and seq is the current cop_seq
619to match against. If warn is true, print appropriate warnings. The out_*
620vars return values, and so are pointers to where the returned values
621should be stored. out_capture, if non-null, requests that the innermost
622instance of the lexical is captured; out_name_sv is set to the innermost
623matched namesv or fake namesv; out_flags returns the flags normally
624associated with the IVX field of a fake namesv.
625
626Note that pad_findlex() is recursive; it recurses up the chain of CVs,
627then comes back down, adding fake entries as it goes. It has to be this way
628because fake namesvs in anon protoypes have to store in NVX the index into
629the parent pad.
dd2155a4
DM
630
631=cut
632*/
633
b5c19bd7
DM
634/* Flags set in the SvIVX field of FAKE namesvs */
635
636#define PAD_FAKELEX_ANON 1 /* the lex is declared in an ANON, or ... */
637#define PAD_FAKELEX_MULTI 2 /* the lex can be instantiated multiple times */
638
639/* the CV has finished being compiled. This is not a sufficient test for
640 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
641#define CvCOMPILED(cv) CvROOT(cv)
642
71f882da
DM
643/* the CV does late binding of its lexicals */
644#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
645
b5c19bd7 646
dd2155a4 647STATIC PADOFFSET
e1ec3a88 648S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
b5c19bd7 649 SV** out_capture, SV** out_name_sv, int *out_flags)
dd2155a4 650{
b5c19bd7
DM
651 I32 offset, new_offset;
652 SV *new_capture;
653 SV **new_capturep;
e1ec3a88 654 const AV *padlist = CvPADLIST(cv);
dd2155a4 655
b5c19bd7 656 *out_flags = 0;
a3985cdc 657
b5c19bd7
DM
658 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
659 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
660 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
dd2155a4 661
b5c19bd7 662 /* first, search this pad */
dd2155a4 663
b5c19bd7
DM
664 if (padlist) { /* not an undef CV */
665 I32 fake_offset = 0;
e1ec3a88 666 const AV *nameav = (AV*)AvARRAY(padlist)[0];
b5c19bd7 667 SV **name_svp = AvARRAY(nameav);
ee6cee0c 668
b5c19bd7 669 for (offset = AvFILLp(nameav); offset > 0; offset--) {
e1ec3a88 670 const SV *namesv = name_svp[offset];
b5c19bd7 671 if (namesv && namesv != &PL_sv_undef
b15aece3 672 && strEQ(SvPVX_const(namesv), name))
b5c19bd7
DM
673 {
674 if (SvFAKE(namesv))
675 fake_offset = offset; /* in case we don't find a real one */
4cf4a199
JH
676 else if ( seq > U_32(SvNVX(namesv)) /* min */
677 && seq <= (U32)SvIVX(namesv)) /* max */
b5c19bd7 678 break;
ee6cee0c
DM
679 }
680 }
681
b5c19bd7
DM
682 if (offset > 0 || fake_offset > 0 ) { /* a match! */
683 if (offset > 0) { /* not fake */
684 fake_offset = 0;
685 *out_name_sv = name_svp[offset]; /* return the namesv */
686
687 /* set PAD_FAKELEX_MULTI if this lex can have multiple
688 * instances. For now, we just test !CvUNIQUE(cv), but
689 * ideally, we should detect my's declared within loops
690 * etc - this would allow a wider range of 'not stayed
691 * shared' warnings. We also treated alreadly-compiled
692 * lexes as not multi as viewed from evals. */
693
694 *out_flags = CvANON(cv) ?
695 PAD_FAKELEX_ANON :
696 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
697 ? PAD_FAKELEX_MULTI : 0;
698
699 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
700 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
4cf4a199 701 PTR2UV(cv), (long)offset, (long)U_32(SvNVX(*out_name_sv)),
b5c19bd7
DM
702 (long)SvIVX(*out_name_sv)));
703 }
704 else { /* fake match */
705 offset = fake_offset;
706 *out_name_sv = name_svp[offset]; /* return the namesv */
707 *out_flags = SvIVX(*out_name_sv);
708 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
19a5c512 709 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7
DM
710 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
711 (unsigned long)SvNVX(*out_name_sv)
712 ));
713 }
dd2155a4 714
b5c19bd7 715 /* return the lex? */
dd2155a4 716
b5c19bd7 717 if (out_capture) {
dd2155a4 718
b5c19bd7
DM
719 /* our ? */
720 if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) {
721 *out_capture = Nullsv;
722 return offset;
723 }
ee6cee0c 724
b5c19bd7
DM
725 /* trying to capture from an anon prototype? */
726 if (CvCOMPILED(cv)
727 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
728 : *out_flags & PAD_FAKELEX_ANON)
729 {
730 if (warn && ckWARN(WARN_CLOSURE))
731 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
732 "Variable \"%s\" is not available", name);
733 *out_capture = Nullsv;
734 }
ee6cee0c 735
b5c19bd7
DM
736 /* real value */
737 else {
738 int newwarn = warn;
739 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
740 && warn && ckWARN(WARN_CLOSURE)) {
741 newwarn = 0;
742 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
743 "Variable \"%s\" will not stay shared", name);
744 }
dd2155a4 745
b5c19bd7
DM
746 if (fake_offset && CvANON(cv)
747 && CvCLONE(cv) &&!CvCLONED(cv))
748 {
749 SV *n;
750 /* not yet caught - look further up */
751 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
752 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
753 PTR2UV(cv)));
754 n = *out_name_sv;
755 pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv),
756 newwarn, out_capture, out_name_sv, out_flags);
757 *out_name_sv = n;
758 return offset;
dd2155a4 759 }
b5c19bd7
DM
760
761 *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
762 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
763 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
764 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 765 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7
DM
766
767 if (SvPADSTALE(*out_capture)) {
768 if (ckWARN(WARN_CLOSURE))
ee6cee0c 769 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
b5c19bd7
DM
770 "Variable \"%s\" is not available", name);
771 *out_capture = Nullsv;
dd2155a4
DM
772 }
773 }
b5c19bd7
DM
774 if (!*out_capture) {
775 if (*name == '@')
776 *out_capture = sv_2mortal((SV*)newAV());
777 else if (*name == '%')
778 *out_capture = sv_2mortal((SV*)newHV());
779 else
780 *out_capture = sv_newmortal();
781 }
dd2155a4 782 }
b5c19bd7
DM
783
784 return offset;
ee6cee0c 785 }
b5c19bd7
DM
786 }
787
788 /* it's not in this pad - try above */
789
790 if (!CvOUTSIDE(cv))
791 return NOT_IN_PAD;
792
793 /* out_capture non-null means caller wants us to capture lex; in
71f882da 794 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 795 new_capturep = out_capture ? out_capture :
71f882da 796 CvLATE(cv) ? Null(SV**) : &new_capture;
b5c19bd7
DM
797
798 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
799 new_capturep, out_name_sv, out_flags);
800 if (offset == NOT_IN_PAD)
801 return NOT_IN_PAD;
802
803 /* found in an outer CV. Add appropriate fake entry to this pad */
804
805 /* don't add new fake entries (via eval) to CVs that we have already
806 * finished compiling, or to undef CVs */
807 if (CvCOMPILED(cv) || !padlist)
808 return 0; /* this dummy (and invalid) value isnt used by the caller */
809
810 {
811 SV *new_namesv;
812 AV *ocomppad_name = PL_comppad_name;
813 PAD *ocomppad = PL_comppad;
814 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
815 PL_comppad = (AV*)AvARRAY(padlist)[1];
816 PL_curpad = AvARRAY(PL_comppad);
817
818 new_offset = pad_add_name(
b15aece3 819 SvPVX_const(*out_name_sv),
b5c19bd7
DM
820 (SvFLAGS(*out_name_sv) & SVpad_TYPED)
821 ? SvSTASH(*out_name_sv) : Nullhv,
822 (SvFLAGS(*out_name_sv) & SVpad_OUR)
823 ? GvSTASH(*out_name_sv) : Nullhv,
824 1 /* fake */
825 );
826
827 new_namesv = AvARRAY(PL_comppad_name)[new_offset];
b19bbeda 828 SvIV_set(new_namesv, *out_flags);
b5c19bd7 829
9d6ce603 830 SvNV_set(new_namesv, (NV)0);
b5c19bd7
DM
831 if (SvFLAGS(new_namesv) & SVpad_OUR) {
832 /* do nothing */
833 }
71f882da 834 else if (CvLATE(cv)) {
b5c19bd7 835 /* delayed creation - just note the offset within parent pad */
9d6ce603 836 SvNV_set(new_namesv, (NV)offset);
b5c19bd7
DM
837 CvCLONE_on(cv);
838 }
839 else {
840 /* immediate creation - capture outer value right now */
841 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
842 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
843 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
844 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 845 }
b5c19bd7
DM
846 *out_name_sv = new_namesv;
847 *out_flags = SvIVX(new_namesv);
848
849 PL_comppad_name = ocomppad_name;
850 PL_comppad = ocomppad;
851 PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **);
dd2155a4 852 }
b5c19bd7 853 return new_offset;
dd2155a4
DM
854}
855
b5c19bd7 856
dd2155a4
DM
857/*
858=for apidoc pad_sv
859
860Get the value at offset po in the current pad.
861Use macro PAD_SV instead of calling this function directly.
862
863=cut
864*/
865
866
867SV *
868Perl_pad_sv(pTHX_ PADOFFSET po)
869{
f3548bdc 870 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 871
dd2155a4
DM
872 if (!po)
873 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
874 DEBUG_X(PerlIO_printf(Perl_debug_log,
875 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 876 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
877 );
878 return PL_curpad[po];
879}
880
881
882/*
883=for apidoc pad_setsv
884
885Set the entry at offset po in the current pad to sv.
886Use the macro PAD_SETSV() rather than calling this function directly.
887
888=cut
889*/
890
891#ifdef DEBUGGING
892void
893Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
894{
f3548bdc 895 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
896
897 DEBUG_X(PerlIO_printf(Perl_debug_log,
898 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 899 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
900 );
901 PL_curpad[po] = sv;
902}
903#endif
904
905
906
907/*
908=for apidoc pad_block_start
909
910Update the pad compilation state variables on entry to a new block
911
912=cut
913*/
914
915/* XXX DAPM perhaps:
916 * - integrate this in general state-saving routine ???
917 * - combine with the state-saving going on in pad_new ???
918 * - introduce a new SAVE type that does all this in one go ?
919 */
920
921void
922Perl_pad_block_start(pTHX_ int full)
923{
f3548bdc 924 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4
DM
925 SAVEI32(PL_comppad_name_floor);
926 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
927 if (full)
928 PL_comppad_name_fill = PL_comppad_name_floor;
929 if (PL_comppad_name_floor < 0)
930 PL_comppad_name_floor = 0;
931 SAVEI32(PL_min_intro_pending);
932 SAVEI32(PL_max_intro_pending);
933 PL_min_intro_pending = 0;
934 SAVEI32(PL_comppad_name_fill);
935 SAVEI32(PL_padix_floor);
936 PL_padix_floor = PL_padix;
937 PL_pad_reset_pending = FALSE;
938}
939
940
941/*
942=for apidoc intro_my
943
944"Introduce" my variables to visible status.
945
946=cut
947*/
948
949U32
950Perl_intro_my(pTHX)
951{
952 SV **svp;
953 SV *sv;
954 I32 i;
955
f3548bdc 956 ASSERT_CURPAD_ACTIVE("intro_my");
dd2155a4
DM
957 if (! PL_min_intro_pending)
958 return PL_cop_seqmax;
959
960 svp = AvARRAY(PL_comppad_name);
961 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
ee6cee0c
DM
962 if ((sv = svp[i]) && sv != &PL_sv_undef
963 && !SvFAKE(sv) && !SvIVX(sv))
964 {
b19bbeda 965 SvIV_set(sv, PAD_MAX); /* Don't know scope end yet. */
9d6ce603 966 SvNV_set(sv, (NV)PL_cop_seqmax);
dd2155a4 967 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
b5c19bd7 968 "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
b15aece3 969 (long)i, SvPVX_const(sv),
4cf4a199 970 (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
dd2155a4
DM
971 );
972 }
973 }
974 PL_min_intro_pending = 0;
975 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
976 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
977 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
978
979 return PL_cop_seqmax++;
980}
981
982/*
983=for apidoc pad_leavemy
984
985Cleanup at end of scope during compilation: set the max seq number for
986lexicals in this scope and warn of any lexicals that never got introduced.
987
988=cut
989*/
990
991void
992Perl_pad_leavemy(pTHX)
993{
994 I32 off;
995 SV **svp = AvARRAY(PL_comppad_name);
dd2155a4
DM
996
997 PL_pad_reset_pending = FALSE;
998
f3548bdc 999 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1000 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1001 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
e1ec3a88 1002 const SV *sv;
ee6cee0c
DM
1003 if ((sv = svp[off]) && sv != &PL_sv_undef
1004 && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
dd2155a4 1005 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
35c1215d 1006 "%"SVf" never introduced", sv);
dd2155a4
DM
1007 }
1008 }
1009 /* "Deintroduce" my variables that are leaving with this scope. */
1010 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
e1ec3a88 1011 const SV *sv;
ee6cee0c
DM
1012 if ((sv = svp[off]) && sv != &PL_sv_undef
1013 && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
1014 {
b19bbeda 1015 SvIV_set(sv, PL_cop_seqmax);
dd2155a4 1016 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
b5c19bd7 1017 "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
b15aece3 1018 (long)off, SvPVX_const(sv),
4cf4a199 1019 (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
dd2155a4
DM
1020 );
1021 }
1022 }
1023 PL_cop_seqmax++;
1024 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1025 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1026}
1027
1028
1029/*
1030=for apidoc pad_swipe
1031
1032Abandon the tmp in the current pad at offset po and replace with a
1033new one.
1034
1035=cut
1036*/
1037
1038void
1039Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1040{
f3548bdc 1041 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1042 if (!PL_curpad)
1043 return;
1044 if (AvARRAY(PL_comppad) != PL_curpad)
1045 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1046 if (!po)
1047 Perl_croak(aTHX_ "panic: pad_swipe po");
1048
1049 DEBUG_X(PerlIO_printf(Perl_debug_log,
1050 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1051 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1052
1053 if (PL_curpad[po])
1054 SvPADTMP_off(PL_curpad[po]);
1055 if (refadjust)
1056 SvREFCNT_dec(PL_curpad[po]);
1057
1058 PL_curpad[po] = NEWSV(1107,0);
1059 SvPADTMP_on(PL_curpad[po]);
1060 if ((I32)po < PL_padix)
1061 PL_padix = po - 1;
1062}
1063
1064
1065/*
1066=for apidoc pad_reset
1067
1068Mark all the current temporaries for reuse
1069
1070=cut
1071*/
1072
1073/* XXX pad_reset() is currently disabled because it results in serious bugs.
1074 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1075 * on the stack by OPs that use them, there are several ways to get an alias
1076 * to a shared TARG. Such an alias will change randomly and unpredictably.
1077 * We avoid doing this until we can think of a Better Way.
1078 * GSAR 97-10-29 */
1079void
1080Perl_pad_reset(pTHX)
1081{
1082#ifdef USE_BROKEN_PAD_RESET
dd2155a4
DM
1083 if (AvARRAY(PL_comppad) != PL_curpad)
1084 Perl_croak(aTHX_ "panic: pad_reset curpad");
1085
1086 DEBUG_X(PerlIO_printf(Perl_debug_log,
1087 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1088 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1089 (long)PL_padix, (long)PL_padix_floor
1090 )
1091 );
1092
1093 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
e1ec3a88 1094 register I32 po;
dd2155a4
DM
1095 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1096 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1097 SvPADTMP_off(PL_curpad[po]);
1098 }
1099 PL_padix = PL_padix_floor;
1100 }
1101#endif
1102 PL_pad_reset_pending = FALSE;
1103}
1104
1105
1106/*
1107=for apidoc pad_tidy
1108
1109Tidy up a pad after we've finished compiling it:
1110 * remove most stuff from the pads of anonsub prototypes;
1111 * give it a @_;
1112 * mark tmps as such.
1113
1114=cut
1115*/
1116
1117/* XXX DAPM surely most of this stuff should be done properly
1118 * at the right time beforehand, rather than going around afterwards
1119 * cleaning up our mistakes ???
1120 */
1121
1122void
1123Perl_pad_tidy(pTHX_ padtidy_type type)
1124{
27da23d5 1125 dVAR;
dd2155a4 1126
f3548bdc 1127 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1128
1129 /* If this CV has had any 'eval-capable' ops planted in it
1130 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1131 * anon prototypes in the chain of CVs should be marked as cloneable,
1132 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1133 * the right CvOUTSIDE.
1134 * If running with -d, *any* sub may potentially have an eval
1135 * excuted within it.
1136 */
1137
1138 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1139 const CV *cv;
b5c19bd7
DM
1140 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1141 if (cv != PL_compcv && CvCOMPILED(cv))
1142 break; /* no need to mark already-compiled code */
1143 if (CvANON(cv)) {
1144 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1145 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1146 CvCLONE_on(cv);
1147 }
1148 }
1149 }
1150
dd2155a4
DM
1151 /* extend curpad to match namepad */
1152 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1153 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1154
1155 if (type == padtidy_SUBCLONE) {
1156 SV **namep = AvARRAY(PL_comppad_name);
504618e9 1157 PADOFFSET ix;
b5c19bd7 1158
dd2155a4
DM
1159 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1160 SV *namesv;
1161
1162 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1163 continue;
1164 /*
1165 * The only things that a clonable function needs in its
b5c19bd7 1166 * pad are anonymous subs.
dd2155a4
DM
1167 * The rest are created anew during cloning.
1168 */
1169 if (!((namesv = namep[ix]) != Nullsv &&
1170 namesv != &PL_sv_undef &&
b15aece3 1171 *SvPVX_const(namesv) == '&'))
dd2155a4
DM
1172 {
1173 SvREFCNT_dec(PL_curpad[ix]);
1174 PL_curpad[ix] = Nullsv;
1175 }
1176 }
1177 }
1178 else if (type == padtidy_SUB) {
1179 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1180 AV *av = newAV(); /* Will be @_ */
1181 av_extend(av, 0);
1182 av_store(PL_comppad, 0, (SV*)av);
11ca45c0 1183 AvREIFY_only(av);
dd2155a4
DM
1184 }
1185
1186 /* XXX DAPM rationalise these two similar branches */
1187
1188 if (type == padtidy_SUB) {
504618e9 1189 PADOFFSET ix;
dd2155a4
DM
1190 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1191 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1192 continue;
1193 if (!SvPADMY(PL_curpad[ix]))
1194 SvPADTMP_on(PL_curpad[ix]);
1195 }
1196 }
1197 else if (type == padtidy_FORMAT) {
504618e9 1198 PADOFFSET ix;
dd2155a4
DM
1199 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1200 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1201 SvPADTMP_on(PL_curpad[ix]);
1202 }
1203 }
f3548bdc 1204 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1205}
1206
1207
1208/*
1209=for apidoc pad_free
1210
1211Free the SV at offet po in the current pad.
1212
1213=cut
1214*/
1215
1216/* XXX DAPM integrate with pad_swipe ???? */
1217void
1218Perl_pad_free(pTHX_ PADOFFSET po)
1219{
f3548bdc 1220 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1221 if (!PL_curpad)
1222 return;
1223 if (AvARRAY(PL_comppad) != PL_curpad)
1224 Perl_croak(aTHX_ "panic: pad_free curpad");
1225 if (!po)
1226 Perl_croak(aTHX_ "panic: pad_free po");
1227
1228 DEBUG_X(PerlIO_printf(Perl_debug_log,
1229 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1230 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1231 );
1232
1233 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1234 SvPADTMP_off(PL_curpad[po]);
1235#ifdef USE_ITHREADS
7e736055
HS
1236 /* SV could be a shared hash key (eg bugid #19022) */
1237 if (
f8c7b90f 1238#ifdef PERL_OLD_COPY_ON_WRITE
7e736055
HS
1239 !SvIsCOW(PL_curpad[po])
1240#else
1241 !SvFAKE(PL_curpad[po])
dd2155a4 1242#endif
7e736055 1243 )
dd2155a4 1244 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
dd2155a4
DM
1245#endif
1246 }
1247 if ((I32)po < PL_padix)
1248 PL_padix = po - 1;
1249}
1250
1251
1252
1253/*
1254=for apidoc do_dump_pad
1255
1256Dump the contents of a padlist
1257
1258=cut
1259*/
1260
1261void
1262Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1263{
e1ec3a88
AL
1264 const AV *pad_name;
1265 const AV *pad;
dd2155a4
DM
1266 SV **pname;
1267 SV **ppad;
dd2155a4
DM
1268 I32 ix;
1269
1270 if (!padlist) {
1271 return;
1272 }
1273 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1274 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1275 pname = AvARRAY(pad_name);
1276 ppad = AvARRAY(pad);
1277 Perl_dump_indent(aTHX_ level, file,
1278 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1279 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1280 );
1281
1282 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1283 const SV *namesv = pname[ix];
dd2155a4
DM
1284 if (namesv && namesv == &PL_sv_undef) {
1285 namesv = Nullsv;
1286 }
1287 if (namesv) {
ee6cee0c
DM
1288 if (SvFAKE(namesv))
1289 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1290 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1291 (int) ix,
1292 PTR2UV(ppad[ix]),
1293 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b15aece3 1294 SvPVX_const(namesv),
b5c19bd7
DM
1295 (unsigned long)SvIVX(namesv),
1296 (unsigned long)SvNVX(namesv)
1297
ee6cee0c
DM
1298 );
1299 else
1300 Perl_dump_indent(aTHX_ level+1, file,
b5c19bd7 1301 "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
ee6cee0c
DM
1302 (int) ix,
1303 PTR2UV(ppad[ix]),
1304 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
4cf4a199 1305 (long)U_32(SvNVX(namesv)),
b5c19bd7 1306 (long)SvIVX(namesv),
b15aece3 1307 SvPVX_const(namesv)
ee6cee0c 1308 );
dd2155a4
DM
1309 }
1310 else if (full) {
1311 Perl_dump_indent(aTHX_ level+1, file,
1312 "%2d. 0x%"UVxf"<%lu>\n",
1313 (int) ix,
1314 PTR2UV(ppad[ix]),
1315 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1316 );
1317 }
1318 }
1319}
1320
1321
1322
1323/*
1324=for apidoc cv_dump
1325
1326dump the contents of a CV
1327
1328=cut
1329*/
1330
1331#ifdef DEBUGGING
1332STATIC void
e1ec3a88 1333S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1334{
e1ec3a88 1335 const CV *outside = CvOUTSIDE(cv);
dd2155a4
DM
1336 AV* padlist = CvPADLIST(cv);
1337
1338 PerlIO_printf(Perl_debug_log,
1339 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1340 title,
1341 PTR2UV(cv),
1342 (CvANON(cv) ? "ANON"
71f882da 1343 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1344 : (cv == PL_main_cv) ? "MAIN"
1345 : CvUNIQUE(cv) ? "UNIQUE"
1346 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1347 PTR2UV(outside),
1348 (!outside ? "null"
1349 : CvANON(outside) ? "ANON"
1350 : (outside == PL_main_cv) ? "MAIN"
1351 : CvUNIQUE(outside) ? "UNIQUE"
1352 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1353
1354 PerlIO_printf(Perl_debug_log,
1355 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1356 do_dump_pad(1, Perl_debug_log, padlist, 1);
1357}
1358#endif /* DEBUGGING */
1359
1360
1361
1362
1363
1364/*
1365=for apidoc cv_clone
1366
1367Clone a CV: make a new CV which points to the same code etc, but which
1368has a newly-created pad built by copying the prototype pad and capturing
1369any outer lexicals.
1370
1371=cut
1372*/
1373
1374CV *
1375Perl_cv_clone(pTHX_ CV *proto)
1376{
27da23d5 1377 dVAR;
dd2155a4
DM
1378 I32 ix;
1379 AV* protopadlist = CvPADLIST(proto);
e1ec3a88
AL
1380 const AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1381 const AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
dd2155a4
DM
1382 SV** pname = AvARRAY(protopad_name);
1383 SV** ppad = AvARRAY(protopad);
e1ec3a88
AL
1384 const I32 fname = AvFILLp(protopad_name);
1385 const I32 fpad = AvFILLp(protopad);
dd2155a4 1386 CV* cv;
b5c19bd7
DM
1387 SV** outpad;
1388 CV* outside;
71f882da 1389 long depth;
dd2155a4
DM
1390
1391 assert(!CvUNIQUE(proto));
1392
71f882da
DM
1393 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1394 * to a prototype; we instead want the cloned parent who called us.
1395 * Note that in general for formats, CvOUTSIDE != find_runcv */
1396
1397 outside = CvOUTSIDE(proto);
1398 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1399 outside = find_runcv(NULL);
1400 depth = CvDEPTH(outside);
1401 assert(depth || SvTYPE(proto) == SVt_PVFM);
1402 if (!depth)
1403 depth = 1;
b5c19bd7
DM
1404 assert(CvPADLIST(outside));
1405
dd2155a4
DM
1406 ENTER;
1407 SAVESPTR(PL_compcv);
1408
1409 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1410 sv_upgrade((SV *)cv, SvTYPE(proto));
7dafbf52 1411 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
dd2155a4
DM
1412 CvCLONED_on(cv);
1413
dd2155a4
DM
1414#ifdef USE_ITHREADS
1415 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1416 : savepv(CvFILE(proto));
1417#else
1418 CvFILE(cv) = CvFILE(proto);
1419#endif
1420 CvGV(cv) = CvGV(proto);
1421 CvSTASH(cv) = CvSTASH(proto);
b34c0dd4 1422 OP_REFCNT_LOCK;
dd2155a4 1423 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1424 OP_REFCNT_UNLOCK;
dd2155a4 1425 CvSTART(cv) = CvSTART(proto);
b5c19bd7
DM
1426 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1427 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
1428
1429 if (SvPOK(proto))
b15aece3 1430 sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
dd2155a4 1431
b7787f18 1432 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
dd2155a4 1433
b5c19bd7 1434 av_fill(PL_comppad, fpad);
dd2155a4
DM
1435 for (ix = fname; ix >= 0; ix--)
1436 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1437
dd2155a4
DM
1438 PL_curpad = AvARRAY(PL_comppad);
1439
71f882da 1440 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
b5c19bd7 1441
dd2155a4
DM
1442 for (ix = fpad; ix > 0; ix--) {
1443 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
71f882da
DM
1444 SV *sv = Nullsv;
1445 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 1446 if (SvFAKE(namesv)) { /* lexical from outside? */
71f882da
DM
1447 sv = outpad[(I32)SvNVX(namesv)];
1448 assert(sv);
1449 /* formats may have an inactive parent */
1450 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1451 if (ckWARN(WARN_CLOSURE))
1452 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
b15aece3 1453 "Variable \"%s\" is not available", SvPVX_const(namesv));
71f882da
DM
1454 sv = Nullsv;
1455 }
1456 else {
1457 assert(!SvPADSTALE(sv));
1458 sv = SvREFCNT_inc(sv);
1459 }
dd2155a4 1460 }
71f882da 1461 if (!sv) {
b15aece3 1462 const char sigil = SvPVX_const(namesv)[0];
e1ec3a88 1463 if (sigil == '&')
dd2155a4 1464 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 1465 else if (sigil == '@')
dd2155a4 1466 sv = (SV*)newAV();
e1ec3a88 1467 else if (sigil == '%')
dd2155a4
DM
1468 sv = (SV*)newHV();
1469 else
1470 sv = NEWSV(0, 0);
235cc2e3 1471 SvPADMY_on(sv);
dd2155a4
DM
1472 }
1473 }
1474 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
71f882da 1475 sv = SvREFCNT_inc(ppad[ix]);
dd2155a4
DM
1476 }
1477 else {
b5c19bd7 1478 sv = NEWSV(0, 0);
dd2155a4 1479 SvPADTMP_on(sv);
dd2155a4 1480 }
71f882da 1481 PL_curpad[ix] = sv;
dd2155a4
DM
1482 }
1483
dd2155a4
DM
1484 DEBUG_Xv(
1485 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1486 cv_dump(outside, "Outside");
1487 cv_dump(proto, "Proto");
1488 cv_dump(cv, "To");
1489 );
1490
1491 LEAVE;
1492
1493 if (CvCONST(cv)) {
b5c19bd7
DM
1494 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1495 * The prototype was marked as a candiate for const-ization,
1496 * so try to grab the current const value, and if successful,
1497 * turn into a const sub:
1498 */
dd2155a4 1499 SV* const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
1500 if (const_sv) {
1501 SvREFCNT_dec(cv);
1502 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1503 }
1504 else {
1505 CvCONST_off(cv);
1506 }
dd2155a4
DM
1507 }
1508
1509 return cv;
1510}
1511
1512
1513/*
1514=for apidoc pad_fixup_inner_anons
1515
1516For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
1517old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1518moved to a pre-existing CV struct.
dd2155a4
DM
1519
1520=cut
1521*/
1522
1523void
1524Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1525{
1526 I32 ix;
66a1b24b
AL
1527 AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
1528 AV * const comppad = (AV*)AvARRAY(padlist)[1];
dd2155a4
DM
1529 SV **namepad = AvARRAY(comppad_name);
1530 SV **curpad = AvARRAY(comppad);
1531 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
e1ec3a88 1532 const SV *namesv = namepad[ix];
dd2155a4 1533 if (namesv && namesv != &PL_sv_undef
b15aece3 1534 && *SvPVX_const(namesv) == '&')
dd2155a4
DM
1535 {
1536 CV *innercv = (CV*)curpad[ix];
7dafbf52
DM
1537 assert(CvWEAKOUTSIDE(innercv));
1538 assert(CvOUTSIDE(innercv) == old_cv);
1539 CvOUTSIDE(innercv) = new_cv;
dd2155a4
DM
1540 }
1541 }
1542}
1543
7dafbf52 1544
dd2155a4
DM
1545/*
1546=for apidoc pad_push
1547
1548Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
1549this depth, in which case don't bother creating a new one. Then give
1550the new pad an @_ in slot zero.
dd2155a4
DM
1551
1552=cut
1553*/
1554
1555void
26019298 1556Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4
DM
1557{
1558 if (depth <= AvFILLp(padlist))
1559 return;
1560
1561 {
1562 SV** svp = AvARRAY(padlist);
1563 AV *newpad = newAV();
1564 SV **oldpad = AvARRAY(svp[depth-1]);
1565 I32 ix = AvFILLp((AV*)svp[1]);
e1ec3a88 1566 const I32 names_fill = AvFILLp((AV*)svp[0]);
dd2155a4 1567 SV** names = AvARRAY(svp[0]);
26019298
AL
1568 AV *av;
1569
dd2155a4
DM
1570 for ( ;ix > 0; ix--) {
1571 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
b15aece3 1572 const char sigil = SvPVX_const(names[ix])[0];
26019298 1573 if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
dd2155a4
DM
1574 /* outer lexical or anon code */
1575 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1576 }
1577 else { /* our own lexical */
26019298
AL
1578 SV *sv;
1579 if (sigil == '@')
1580 sv = (SV*)newAV();
1581 else if (sigil == '%')
1582 sv = (SV*)newHV();
dd2155a4 1583 else
26019298
AL
1584 sv = NEWSV(0, 0);
1585 av_store(newpad, ix, sv);
dd2155a4
DM
1586 SvPADMY_on(sv);
1587 }
1588 }
1589 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
26019298 1590 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
dd2155a4
DM
1591 }
1592 else {
1593 /* save temporaries on recursion? */
26019298
AL
1594 SV *sv = NEWSV(0, 0);
1595 av_store(newpad, ix, sv);
dd2155a4
DM
1596 SvPADTMP_on(sv);
1597 }
1598 }
26019298
AL
1599 av = newAV();
1600 av_extend(av, 0);
1601 av_store(newpad, 0, (SV*)av);
11ca45c0 1602 AvREIFY_only(av);
26019298 1603
dd2155a4
DM
1604 av_store(padlist, depth, (SV*)newpad);
1605 AvFILLp(padlist) = depth;
1606 }
1607}
b21dc031
AL
1608
1609
1610HV *
1611Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1612{
1613 SV** const av = av_fetch(PL_comppad_name, po, FALSE);
1614 if ( SvFLAGS(*av) & SVpad_TYPED ) {
1615 return SvSTASH(*av);
1616 }
1617 return Nullhv;
1618}
66610fdd
RGS
1619
1620/*
1621 * Local variables:
1622 * c-indentation-style: bsd
1623 * c-basic-offset: 4
1624 * indent-tabs-mode: t
1625 * End:
1626 *
37442d52
RGS
1627 * ex: set ts=8 sts=4 sw=4 noet:
1628 */