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