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