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