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