This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove PMROOT and replace it with a small shell script. Er, magic.
[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--) {
258 SV *namesv = namepad[ix];
259 if (namesv && namesv != &PL_sv_undef
7dafbf52 260 && *SvPVX(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
DM
331{
332 PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
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))
520 && strEQ(name, SvPVX(sv)))
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)
539 && strEQ(name, SvPVX(sv)))
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)
589 && strEQ(SvPVX(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
DM
671 if (namesv && namesv != &PL_sv_undef
672 && strEQ(SvPVX(namesv), name))
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(
819 SvPVX(*out_name_sv),
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",
dd2155a4 969 (long)i, SvPVX(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",
dd2155a4 1018 (long)off, SvPVX(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
DM
1126 PADOFFSET ix;
1127
f3548bdc 1128 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1129
1130 /* If this CV has had any 'eval-capable' ops planted in it
1131 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1132 * anon prototypes in the chain of CVs should be marked as cloneable,
1133 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1134 * the right CvOUTSIDE.
1135 * If running with -d, *any* sub may potentially have an eval
1136 * excuted within it.
1137 */
1138
1139 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1140 const CV *cv;
b5c19bd7
DM
1141 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1142 if (cv != PL_compcv && CvCOMPILED(cv))
1143 break; /* no need to mark already-compiled code */
1144 if (CvANON(cv)) {
1145 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1146 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1147 CvCLONE_on(cv);
1148 }
1149 }
1150 }
1151
dd2155a4
DM
1152 /* extend curpad to match namepad */
1153 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1154 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1155
1156 if (type == padtidy_SUBCLONE) {
1157 SV **namep = AvARRAY(PL_comppad_name);
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 &&
b5c19bd7 1171 *SvPVX(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) {
1189 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1190 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1191 continue;
1192 if (!SvPADMY(PL_curpad[ix]))
1193 SvPADTMP_on(PL_curpad[ix]);
1194 }
1195 }
1196 else if (type == padtidy_FORMAT) {
1197 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1198 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1199 SvPADTMP_on(PL_curpad[ix]);
1200 }
1201 }
f3548bdc 1202 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1203}
1204
1205
1206/*
1207=for apidoc pad_free
1208
1209Free the SV at offet po in the current pad.
1210
1211=cut
1212*/
1213
1214/* XXX DAPM integrate with pad_swipe ???? */
1215void
1216Perl_pad_free(pTHX_ PADOFFSET po)
1217{
f3548bdc 1218 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1219 if (!PL_curpad)
1220 return;
1221 if (AvARRAY(PL_comppad) != PL_curpad)
1222 Perl_croak(aTHX_ "panic: pad_free curpad");
1223 if (!po)
1224 Perl_croak(aTHX_ "panic: pad_free po");
1225
1226 DEBUG_X(PerlIO_printf(Perl_debug_log,
1227 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1228 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1229 );
1230
1231 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1232 SvPADTMP_off(PL_curpad[po]);
1233#ifdef USE_ITHREADS
7e736055
HS
1234 /* SV could be a shared hash key (eg bugid #19022) */
1235 if (
dd2155a4 1236#ifdef PERL_COPY_ON_WRITE
7e736055
HS
1237 !SvIsCOW(PL_curpad[po])
1238#else
1239 !SvFAKE(PL_curpad[po])
dd2155a4 1240#endif
7e736055 1241 )
dd2155a4 1242 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
dd2155a4
DM
1243#endif
1244 }
1245 if ((I32)po < PL_padix)
1246 PL_padix = po - 1;
1247}
1248
1249
1250
1251/*
1252=for apidoc do_dump_pad
1253
1254Dump the contents of a padlist
1255
1256=cut
1257*/
1258
1259void
1260Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1261{
e1ec3a88
AL
1262 const AV *pad_name;
1263 const AV *pad;
dd2155a4
DM
1264 SV **pname;
1265 SV **ppad;
dd2155a4
DM
1266 I32 ix;
1267
1268 if (!padlist) {
1269 return;
1270 }
1271 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1272 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1273 pname = AvARRAY(pad_name);
1274 ppad = AvARRAY(pad);
1275 Perl_dump_indent(aTHX_ level, file,
1276 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1277 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1278 );
1279
1280 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1281 const SV *namesv = pname[ix];
dd2155a4
DM
1282 if (namesv && namesv == &PL_sv_undef) {
1283 namesv = Nullsv;
1284 }
1285 if (namesv) {
ee6cee0c
DM
1286 if (SvFAKE(namesv))
1287 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1288 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1289 (int) ix,
1290 PTR2UV(ppad[ix]),
1291 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b5c19bd7
DM
1292 SvPVX(namesv),
1293 (unsigned long)SvIVX(namesv),
1294 (unsigned long)SvNVX(namesv)
1295
ee6cee0c
DM
1296 );
1297 else
1298 Perl_dump_indent(aTHX_ level+1, file,
b5c19bd7 1299 "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
ee6cee0c
DM
1300 (int) ix,
1301 PTR2UV(ppad[ix]),
1302 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
4cf4a199 1303 (long)U_32(SvNVX(namesv)),
b5c19bd7 1304 (long)SvIVX(namesv),
e9d09c08 1305 SvPVX(namesv)
ee6cee0c 1306 );
dd2155a4
DM
1307 }
1308 else if (full) {
1309 Perl_dump_indent(aTHX_ level+1, file,
1310 "%2d. 0x%"UVxf"<%lu>\n",
1311 (int) ix,
1312 PTR2UV(ppad[ix]),
1313 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1314 );
1315 }
1316 }
1317}
1318
1319
1320
1321/*
1322=for apidoc cv_dump
1323
1324dump the contents of a CV
1325
1326=cut
1327*/
1328
1329#ifdef DEBUGGING
1330STATIC void
e1ec3a88 1331S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1332{
e1ec3a88 1333 const CV *outside = CvOUTSIDE(cv);
dd2155a4
DM
1334 AV* padlist = CvPADLIST(cv);
1335
1336 PerlIO_printf(Perl_debug_log,
1337 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1338 title,
1339 PTR2UV(cv),
1340 (CvANON(cv) ? "ANON"
71f882da 1341 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1342 : (cv == PL_main_cv) ? "MAIN"
1343 : CvUNIQUE(cv) ? "UNIQUE"
1344 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1345 PTR2UV(outside),
1346 (!outside ? "null"
1347 : CvANON(outside) ? "ANON"
1348 : (outside == PL_main_cv) ? "MAIN"
1349 : CvUNIQUE(outside) ? "UNIQUE"
1350 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1351
1352 PerlIO_printf(Perl_debug_log,
1353 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1354 do_dump_pad(1, Perl_debug_log, padlist, 1);
1355}
1356#endif /* DEBUGGING */
1357
1358
1359
1360
1361
1362/*
1363=for apidoc cv_clone
1364
1365Clone a CV: make a new CV which points to the same code etc, but which
1366has a newly-created pad built by copying the prototype pad and capturing
1367any outer lexicals.
1368
1369=cut
1370*/
1371
1372CV *
1373Perl_cv_clone(pTHX_ CV *proto)
1374{
27da23d5 1375 dVAR;
dd2155a4
DM
1376 I32 ix;
1377 AV* protopadlist = CvPADLIST(proto);
e1ec3a88
AL
1378 const AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1379 const AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
dd2155a4
DM
1380 SV** pname = AvARRAY(protopad_name);
1381 SV** ppad = AvARRAY(protopad);
e1ec3a88
AL
1382 const I32 fname = AvFILLp(protopad_name);
1383 const I32 fpad = AvFILLp(protopad);
dd2155a4 1384 CV* cv;
b5c19bd7
DM
1385 SV** outpad;
1386 CV* outside;
71f882da 1387 long depth;
dd2155a4
DM
1388
1389 assert(!CvUNIQUE(proto));
1390
71f882da
DM
1391 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1392 * to a prototype; we instead want the cloned parent who called us.
1393 * Note that in general for formats, CvOUTSIDE != find_runcv */
1394
1395 outside = CvOUTSIDE(proto);
1396 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1397 outside = find_runcv(NULL);
1398 depth = CvDEPTH(outside);
1399 assert(depth || SvTYPE(proto) == SVt_PVFM);
1400 if (!depth)
1401 depth = 1;
b5c19bd7
DM
1402 assert(CvPADLIST(outside));
1403
dd2155a4
DM
1404 ENTER;
1405 SAVESPTR(PL_compcv);
1406
1407 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1408 sv_upgrade((SV *)cv, SvTYPE(proto));
7dafbf52 1409 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
dd2155a4
DM
1410 CvCLONED_on(cv);
1411
dd2155a4
DM
1412#ifdef USE_ITHREADS
1413 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1414 : savepv(CvFILE(proto));
1415#else
1416 CvFILE(cv) = CvFILE(proto);
1417#endif
1418 CvGV(cv) = CvGV(proto);
1419 CvSTASH(cv) = CvSTASH(proto);
b34c0dd4 1420 OP_REFCNT_LOCK;
dd2155a4 1421 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1422 OP_REFCNT_UNLOCK;
dd2155a4 1423 CvSTART(cv) = CvSTART(proto);
b5c19bd7
DM
1424 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1425 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
1426
1427 if (SvPOK(proto))
1428 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1429
b7787f18 1430 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
dd2155a4 1431
b5c19bd7 1432 av_fill(PL_comppad, fpad);
dd2155a4
DM
1433 for (ix = fname; ix >= 0; ix--)
1434 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1435
dd2155a4
DM
1436 PL_curpad = AvARRAY(PL_comppad);
1437
71f882da 1438 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
b5c19bd7 1439
dd2155a4
DM
1440 for (ix = fpad; ix > 0; ix--) {
1441 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
71f882da
DM
1442 SV *sv = Nullsv;
1443 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 1444 if (SvFAKE(namesv)) { /* lexical from outside? */
71f882da
DM
1445 sv = outpad[(I32)SvNVX(namesv)];
1446 assert(sv);
1447 /* formats may have an inactive parent */
1448 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1449 if (ckWARN(WARN_CLOSURE))
1450 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1451 "Variable \"%s\" is not available", SvPVX(namesv));
1452 sv = Nullsv;
1453 }
1454 else {
1455 assert(!SvPADSTALE(sv));
1456 sv = SvREFCNT_inc(sv);
1457 }
dd2155a4 1458 }
71f882da 1459 if (!sv) {
e1ec3a88
AL
1460 const char sigil = SvPVX(namesv)[0];
1461 if (sigil == '&')
dd2155a4 1462 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 1463 else if (sigil == '@')
dd2155a4 1464 sv = (SV*)newAV();
e1ec3a88 1465 else if (sigil == '%')
dd2155a4
DM
1466 sv = (SV*)newHV();
1467 else
1468 sv = NEWSV(0, 0);
235cc2e3 1469 SvPADMY_on(sv);
dd2155a4
DM
1470 }
1471 }
1472 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
71f882da 1473 sv = SvREFCNT_inc(ppad[ix]);
dd2155a4
DM
1474 }
1475 else {
b5c19bd7 1476 sv = NEWSV(0, 0);
dd2155a4 1477 SvPADTMP_on(sv);
dd2155a4 1478 }
71f882da 1479 PL_curpad[ix] = sv;
dd2155a4
DM
1480 }
1481
dd2155a4
DM
1482 DEBUG_Xv(
1483 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1484 cv_dump(outside, "Outside");
1485 cv_dump(proto, "Proto");
1486 cv_dump(cv, "To");
1487 );
1488
1489 LEAVE;
1490
1491 if (CvCONST(cv)) {
b5c19bd7
DM
1492 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1493 * The prototype was marked as a candiate for const-ization,
1494 * so try to grab the current const value, and if successful,
1495 * turn into a const sub:
1496 */
dd2155a4 1497 SV* const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
1498 if (const_sv) {
1499 SvREFCNT_dec(cv);
1500 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1501 }
1502 else {
1503 CvCONST_off(cv);
1504 }
dd2155a4
DM
1505 }
1506
1507 return cv;
1508}
1509
1510
1511/*
1512=for apidoc pad_fixup_inner_anons
1513
1514For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
1515old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1516moved to a pre-existing CV struct.
dd2155a4
DM
1517
1518=cut
1519*/
1520
1521void
1522Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1523{
1524 I32 ix;
1525 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1526 AV *comppad = (AV*)AvARRAY(padlist)[1];
1527 SV **namepad = AvARRAY(comppad_name);
1528 SV **curpad = AvARRAY(comppad);
1529 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
e1ec3a88 1530 const SV *namesv = namepad[ix];
dd2155a4
DM
1531 if (namesv && namesv != &PL_sv_undef
1532 && *SvPVX(namesv) == '&')
1533 {
1534 CV *innercv = (CV*)curpad[ix];
7dafbf52
DM
1535 assert(CvWEAKOUTSIDE(innercv));
1536 assert(CvOUTSIDE(innercv) == old_cv);
1537 CvOUTSIDE(innercv) = new_cv;
dd2155a4
DM
1538 }
1539 }
1540}
1541
7dafbf52 1542
dd2155a4
DM
1543/*
1544=for apidoc pad_push
1545
1546Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
1547this depth, in which case don't bother creating a new one. Then give
1548the new pad an @_ in slot zero.
dd2155a4
DM
1549
1550=cut
1551*/
1552
1553void
26019298 1554Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4
DM
1555{
1556 if (depth <= AvFILLp(padlist))
1557 return;
1558
1559 {
1560 SV** svp = AvARRAY(padlist);
1561 AV *newpad = newAV();
1562 SV **oldpad = AvARRAY(svp[depth-1]);
1563 I32 ix = AvFILLp((AV*)svp[1]);
e1ec3a88 1564 const I32 names_fill = AvFILLp((AV*)svp[0]);
dd2155a4 1565 SV** names = AvARRAY(svp[0]);
26019298
AL
1566 AV *av;
1567
dd2155a4
DM
1568 for ( ;ix > 0; ix--) {
1569 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
26019298
AL
1570 const char sigil = SvPVX(names[ix])[0];
1571 if ((SvFLAGS(names[ix]) & SVf_FAKE) || sigil == '&') {
dd2155a4
DM
1572 /* outer lexical or anon code */
1573 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1574 }
1575 else { /* our own lexical */
26019298
AL
1576 SV *sv;
1577 if (sigil == '@')
1578 sv = (SV*)newAV();
1579 else if (sigil == '%')
1580 sv = (SV*)newHV();
dd2155a4 1581 else
26019298
AL
1582 sv = NEWSV(0, 0);
1583 av_store(newpad, ix, sv);
dd2155a4
DM
1584 SvPADMY_on(sv);
1585 }
1586 }
1587 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
26019298 1588 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
dd2155a4
DM
1589 }
1590 else {
1591 /* save temporaries on recursion? */
26019298
AL
1592 SV *sv = NEWSV(0, 0);
1593 av_store(newpad, ix, sv);
dd2155a4
DM
1594 SvPADTMP_on(sv);
1595 }
1596 }
26019298
AL
1597 av = newAV();
1598 av_extend(av, 0);
1599 av_store(newpad, 0, (SV*)av);
11ca45c0 1600 AvREIFY_only(av);
26019298 1601
dd2155a4
DM
1602 av_store(padlist, depth, (SV*)newpad);
1603 AvFILLp(padlist) = depth;
1604 }
1605}
b21dc031
AL
1606
1607
1608HV *
1609Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1610{
1611 SV** const av = av_fetch(PL_comppad_name, po, FALSE);
1612 if ( SvFLAGS(*av) & SVpad_TYPED ) {
1613 return SvSTASH(*av);
1614 }
1615 return Nullhv;
1616}
66610fdd
RGS
1617
1618/*
1619 * Local variables:
1620 * c-indentation-style: bsd
1621 * c-basic-offset: 4
1622 * indent-tabs-mode: t
1623 * End:
1624 *
37442d52
RGS
1625 * ex: set ts=8 sts=4 sw=4 noet:
1626 */