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