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