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