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