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