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