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