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