This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
CV-based slab allocation for ops
[perl5.git] / pad.c
1 /*    pad.c
2  *
3  *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  */
9
10 /*
11  *  'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12  *   might say, among those queer Bucklanders, being brought up anyhow in
13  *   Brandy Hall.  A regular warren, by all accounts.  Old Master Gorbadoc
14  *   never had fewer than a couple of hundred relations in the place.
15  *   Mr. Bilbo never did a kinder deed than when he brought the lad back
16  *   to live among decent folk.'                           --the Gaffer
17  *
18  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
19  */
20
21 /* XXX DAPM
22  * As of Sept 2002, this file is new and may be in a state of flux for
23  * a while. I've marked things I intent to come back and look at further
24  * with an 'XXX DAPM' comment.
25  */
26
27 /*
28 =head1 Pad Data Structures
29
30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
31
32 CV's can have CvPADLIST(cv) set to point to an AV.  This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
34 per-thread values.
35
36 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing). Require'd files are simply evals without any outer lexical
39 scope.
40
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub).
44
45 The CvPADLIST AV has the REFCNT of its component items managed "manually"
46 (mostly in pad.c) rather than by normal av.c rules.  So we turn off AvREAL
47 just before freeing it, to let av.c know not to touch the entries.
48 The items in the AV are not SVs as for a normal AV, but other AVs:
49
50 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
51 the "static type information" for lexicals.
52
53 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
54 depth of recursion into the CV.
55 The 0'th slot of a frame AV is an AV which is @_.
56 other entries are storage for variables and op targets.
57
58 Iterating over the names AV iterates over all possible pad
59 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
61
62 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time.  These don't have names by which they
65 can be looked up from Perl code at run time through eval"" like
66 my/our variables can be.  Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
69
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH).  During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
75
76    COP_SEQ_RANGE_LOW        _HIGH
77    -----------------        -----
78    PERL_PADSEQ_INTRO            0   variable not yet introduced:   { my ($x
79    valid-seq#   PERL_PADSEQ_INTRO   variable in scope:             { my ($x)
80    valid-seq#          valid-seq#   compilation of scope complete: { my ($x) }
81
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type.  For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected).  SvUVX is
86 sometimes hijacked to store the generation number during compilation.
87
88 If SvFAKE is set on the name SV, then that slot in the frame AV is
89 a REFCNT'ed reference to a lexical from "outside". In this case,
90 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
91 in scope throughout. Instead xhigh stores some flags containing info about
92 the real lexical (is it declared in an anon, and is it capable of being
93 instantiated multiple times?), and for fake ANONs, xlow contains the index
94 within the parent's pad where the lexical's value is stored, to make
95 cloning quicker.
96
97 If the 'name' is '&' the corresponding entry in frame AV
98 is a CV representing a possible closure.
99 (SvFAKE and name of '&' is not a meaningful combination currently but could
100 become so if C<my sub foo {}> is implemented.)
101
102 Note that formats are treated as anon subs, and are cloned each time
103 write is called (if necessary).
104
105 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
106 and set on scope exit. This allows the 'Variable $x is not available' warning
107 to be generated in evals, such as 
108
109     { my $x = 1; sub f { eval '$x'} } f();
110
111 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
112
113 =for apidoc AmxU|AV *|PL_comppad_name
114
115 During compilation, this points to the array containing the names part
116 of the pad for the currently-compiling code.
117
118 =for apidoc AmxU|AV *|PL_comppad
119
120 During compilation, this points to the array containing the values
121 part of the pad for the currently-compiling code.  (At runtime a CV may
122 have many such value arrays; at compile time just one is constructed.)
123 At runtime, this points to the array containing the currently-relevant
124 values for the pad for the currently-executing code.
125
126 =for apidoc AmxU|SV **|PL_curpad
127
128 Points directly to the body of the L</PL_comppad> array.
129 (I.e., this is C<AvARRAY(PL_comppad)>.)
130
131 =cut
132 */
133
134
135 #include "EXTERN.h"
136 #define PERL_IN_PAD_C
137 #include "perl.h"
138 #include "keywords.h"
139
140 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
141   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
142 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
143   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
144
145 #define PARENT_PAD_INDEX_set(sv,val)            \
146   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define PARENT_FAKELEX_FLAGS_set(sv,val)        \
148   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
149
150 /*
151 =for apidoc mx|void|pad_peg|const char *s
152
153 When PERL_MAD is enabled, this is a small no-op function that gets called
154 at the start of each pad-related function.  It can be breakpointed to
155 track all pad operations.  The parameter is a string indicating the type
156 of pad operation being performed.
157
158 =cut
159 */
160
161 #ifdef PERL_MAD
162 void pad_peg(const char* s) {
163     static int pegcnt; /* XXX not threadsafe */
164     PERL_UNUSED_ARG(s);
165
166     PERL_ARGS_ASSERT_PAD_PEG;
167
168     pegcnt++;
169 }
170 #endif
171
172 /*
173 This is basically sv_eq_flags() in sv.c, but we avoid the magic
174 and bytes checking.
175 */
176
177 static bool
178 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
179     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
180         const char *pv1 = SvPVX_const(sv);
181         STRLEN cur1     = SvCUR(sv);
182         const char *pv2 = pv;
183         STRLEN cur2     = pvlen;
184         if (PL_encoding) {
185               SV* svrecode = NULL;
186               if (SvUTF8(sv)) {
187                    svrecode = newSVpvn(pv2, cur2);
188                    sv_recode_to_utf8(svrecode, PL_encoding);
189                    pv2      = SvPV_const(svrecode, cur2);
190               }
191               else {
192                    svrecode = newSVpvn(pv1, cur1);
193                    sv_recode_to_utf8(svrecode, PL_encoding);
194                    pv1      = SvPV_const(svrecode, cur1);
195               }
196               SvREFCNT_dec(svrecode);
197         }
198         if (flags & SVf_UTF8)
199             return (bytes_cmp_utf8(
200                         (const U8*)pv1, cur1,
201                         (const U8*)pv2, cur2) == 0);
202         else
203             return (bytes_cmp_utf8(
204                         (const U8*)pv2, cur2,
205                         (const U8*)pv1, cur1) == 0);
206     }
207     else
208         return ((SvPVX_const(sv) == pv)
209                     || memEQ(SvPVX_const(sv), pv, pvlen));
210 }
211
212
213 /*
214 =for apidoc Am|PADLIST *|pad_new|int flags
215
216 Create a new padlist, updating the global variables for the
217 currently-compiling padlist to point to the new padlist.  The following
218 flags can be OR'ed together:
219
220     padnew_CLONE        this pad is for a cloned CV
221     padnew_SAVE         save old globals on the save stack
222     padnew_SAVESUB      also save extra stuff for start of sub
223
224 =cut
225 */
226
227 PADLIST *
228 Perl_pad_new(pTHX_ int flags)
229 {
230     dVAR;
231     AV *padlist, *padname, *pad;
232     SV **ary;
233
234     ASSERT_CURPAD_LEGAL("pad_new");
235
236     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
237      * vars (based on flags) rather than storing vals + addresses for
238      * each individually. Also see pad_block_start.
239      * XXX DAPM Try to see whether all these conditionals are required
240      */
241
242     /* save existing state, ... */
243
244     if (flags & padnew_SAVE) {
245         SAVECOMPPAD();
246         SAVESPTR(PL_comppad_name);
247         if (! (flags & padnew_CLONE)) {
248             SAVEI32(PL_padix);
249             SAVEI32(PL_comppad_name_fill);
250             SAVEI32(PL_min_intro_pending);
251             SAVEI32(PL_max_intro_pending);
252             SAVEBOOL(PL_cv_has_eval);
253             if (flags & padnew_SAVESUB) {
254                 SAVEBOOL(PL_pad_reset_pending);
255             }
256         }
257     }
258     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
259      * saved - check at some pt that this is okay */
260
261     /* ... create new pad ... */
262
263     padlist     = newAV();
264     padname     = newAV();
265     pad         = newAV();
266
267     if (flags & padnew_CLONE) {
268         /* XXX DAPM  I dont know why cv_clone needs it
269          * doing differently yet - perhaps this separate branch can be
270          * dispensed with eventually ???
271          */
272
273         AV * const a0 = newAV();                        /* will be @_ */
274         av_store(pad, 0, MUTABLE_SV(a0));
275         AvREIFY_only(a0);
276     }
277     else {
278         av_store(pad, 0, NULL);
279     }
280
281     /* Most subroutines never recurse, hence only need 2 entries in the padlist
282        array - names, and depth=1.  The default for av_store() is to allocate
283        0..3, and even an explicit call to av_extend() with <3 will be rounded
284        up, so we inline the allocation of the array here.  */
285     Newx(ary, 2, SV*);
286     AvFILLp(padlist) = 1;
287     AvMAX(padlist) = 1;
288     AvALLOC(padlist) = ary;
289     AvARRAY(padlist) = ary;
290     ary[0] = MUTABLE_SV(padname);
291     ary[1] = MUTABLE_SV(pad);
292
293     /* ... then update state variables */
294
295     PL_comppad_name     = padname;
296     PL_comppad          = pad;
297     PL_curpad           = AvARRAY(pad);
298
299     if (! (flags & padnew_CLONE)) {
300         PL_comppad_name_fill = 0;
301         PL_min_intro_pending = 0;
302         PL_padix             = 0;
303         PL_cv_has_eval       = 0;
304     }
305
306     DEBUG_X(PerlIO_printf(Perl_debug_log,
307           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
308               " name=0x%"UVxf" flags=0x%"UVxf"\n",
309           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
310               PTR2UV(padname), (UV)flags
311         )
312     );
313
314     return (PADLIST*)padlist;
315 }
316
317
318 /*
319 =head1 Embedding Functions
320
321 =for apidoc cv_undef
322
323 Clear out all the active components of a CV. This can happen either
324 by an explicit C<undef &foo>, or by the reference count going to zero.
325 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
326 children can still follow the full lexical scope chain.
327
328 =cut
329 */
330
331 void
332 Perl_cv_undef(pTHX_ CV *cv)
333 {
334     dVAR;
335     const PADLIST *padlist = CvPADLIST(cv);
336     bool const slabbed = !!CvSLABBED(cv);
337
338     PERL_ARGS_ASSERT_CV_UNDEF;
339
340     DEBUG_X(PerlIO_printf(Perl_debug_log,
341           "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
342             PTR2UV(cv), PTR2UV(PL_comppad))
343     );
344
345     if (CvFILE(cv) && CvDYNFILE(cv)) {
346         Safefree(CvFILE(cv));
347     }
348     CvFILE(cv) = NULL;
349
350     CvSLABBED_off(cv);
351     if (!CvISXSUB(cv) && CvROOT(cv)) {
352         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
353             Perl_croak(aTHX_ "Can't undef active subroutine");
354         ENTER;
355
356         PAD_SAVE_SETNULLPAD();
357
358 #ifndef PL_OP_SLAB_ALLOC
359         if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
360 #endif
361         op_free(CvROOT(cv));
362         CvROOT(cv) = NULL;
363         CvSTART(cv) = NULL;
364         LEAVE;
365     }
366 #ifndef PL_OP_SLAB_ALLOC
367     else if (slabbed && CvSTART(cv)) {
368         ENTER;
369         PAD_SAVE_SETNULLPAD();
370
371         /* discard any leaked ops */
372         opslab_force_free((OPSLAB *)CvSTART(cv));
373         CvSTART(cv) = NULL;
374
375         LEAVE;
376     }
377 # ifdef DEBUGGING
378     else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
379 # endif
380 #endif
381     SvPOK_off(MUTABLE_SV(cv));          /* forget prototype */
382     CvGV_set(cv, NULL);
383
384     /* This statement and the subsequence if block was pad_undef().  */
385     pad_peg("pad_undef");
386
387     if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
388         ) {
389         I32 ix;
390
391         /* Free the padlist associated with a CV.
392            If parts of it happen to be current, we null the relevant PL_*pad*
393            global vars so that we don't have any dangling references left.
394            We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
395            subs to the outer of this cv.  */
396
397         DEBUG_X(PerlIO_printf(Perl_debug_log,
398                               "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
399                               PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
400                 );
401
402         /* detach any '&' anon children in the pad; if afterwards they
403          * are still live, fix up their CvOUTSIDEs to point to our outside,
404          * bypassing us. */
405         /* XXX DAPM for efficiency, we should only do this if we know we have
406          * children, or integrate this loop with general cleanup */
407
408         if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
409             CV * const outercv = CvOUTSIDE(cv);
410             const U32 seq = CvOUTSIDE_SEQ(cv);
411             AV *  const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
412             SV ** const namepad = AvARRAY(comppad_name);
413             AV *  const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
414             SV ** const curpad = AvARRAY(comppad);
415             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
416                 SV * const namesv = namepad[ix];
417                 if (namesv && namesv != &PL_sv_undef
418                     && *SvPVX_const(namesv) == '&')
419                     {
420                         CV * const innercv = MUTABLE_CV(curpad[ix]);
421                         U32 inner_rc = SvREFCNT(innercv);
422                         assert(inner_rc);
423                         assert(SvTYPE(innercv) != SVt_PVFM);
424                         namepad[ix] = NULL;
425                         SvREFCNT_dec(namesv);
426
427                         if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
428                             curpad[ix] = NULL;
429                             SvREFCNT_dec(innercv);
430                             inner_rc--;
431                         }
432
433                         /* in use, not just a prototype */
434                         if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
435                             assert(CvWEAKOUTSIDE(innercv));
436                             /* don't relink to grandfather if he's being freed */
437                             if (outercv && SvREFCNT(outercv)) {
438                                 CvWEAKOUTSIDE_off(innercv);
439                                 CvOUTSIDE(innercv) = outercv;
440                                 CvOUTSIDE_SEQ(innercv) = seq;
441                                 SvREFCNT_inc_simple_void_NN(outercv);
442                             }
443                             else {
444                                 CvOUTSIDE(innercv) = NULL;
445                             }
446                         }
447                     }
448             }
449         }
450
451         ix = AvFILLp(padlist);
452         while (ix > 0) {
453             SV* const sv = AvARRAY(padlist)[ix--];
454             if (sv) {
455                 if (sv == (const SV *)PL_comppad) {
456                     PL_comppad = NULL;
457                     PL_curpad = NULL;
458                 }
459                 SvREFCNT_dec(sv);
460             }
461         }
462         {
463             SV *const sv = AvARRAY(padlist)[0];
464             if (sv == (const SV *)PL_comppad_name)
465                 PL_comppad_name = NULL;
466             SvREFCNT_dec(sv);
467         }
468         AvREAL_off(CvPADLIST(cv));
469         SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
470         CvPADLIST(cv) = NULL;
471     }
472
473
474     /* remove CvOUTSIDE unless this is an undef rather than a free */
475     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
476         if (!CvWEAKOUTSIDE(cv))
477             SvREFCNT_dec(CvOUTSIDE(cv));
478         CvOUTSIDE(cv) = NULL;
479     }
480     if (CvCONST(cv)) {
481         SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
482         CvCONST_off(cv);
483     }
484     if (CvISXSUB(cv) && CvXSUB(cv)) {
485         CvXSUB(cv) = NULL;
486     }
487     /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
488      * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
489      * to choose an error message */
490     CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
491 }
492
493 #ifndef PL_OP_SLAB_ALLOC
494 void
495 Perl_cv_forget_slab(pTHX_ CV *cv)
496 {
497     const bool slabbed = !!CvSLABBED(cv);
498
499     PERL_ARGS_ASSERT_CV_FORGET_SLAB;
500
501     if (!slabbed) return;
502
503     CvSLABBED_off(cv);
504
505     if      (CvROOT(cv))  OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
506     else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
507 # ifdef DEBUGGING
508     else if (slabbed)     Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
509 # endif
510 }
511 #endif
512
513 /*
514 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
515
516 Allocates a place in the currently-compiling
517 pad (via L<perlapi/pad_alloc>) and
518 then stores a name for that entry.  I<namesv> is adopted and becomes the
519 name entry; it must already contain the name string and be sufficiently
520 upgraded.  I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
521 added to I<namesv>.  None of the other
522 processing of L<perlapi/pad_add_name_pvn>
523 is done.  Returns the offset of the allocated pad slot.
524
525 =cut
526 */
527
528 static PADOFFSET
529 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
530 {
531     dVAR;
532     const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
533
534     PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
535
536     ASSERT_CURPAD_ACTIVE("pad_alloc_name");
537
538     if (typestash) {
539         assert(SvTYPE(namesv) == SVt_PVMG);
540         SvPAD_TYPED_on(namesv);
541         SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
542     }
543     if (ourstash) {
544         SvPAD_OUR_on(namesv);
545         SvOURSTASH_set(namesv, ourstash);
546         SvREFCNT_inc_simple_void_NN(ourstash);
547     }
548     else if (flags & padadd_STATE) {
549         SvPAD_STATE_on(namesv);
550     }
551
552     av_store(PL_comppad_name, offset, namesv);
553     return offset;
554 }
555
556 /*
557 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
558
559 Allocates a place in the currently-compiling pad for a named lexical
560 variable.  Stores the name and other metadata in the name part of the
561 pad, and makes preparations to manage the variable's lexical scoping.
562 Returns the offset of the allocated pad slot.
563
564 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
565 If I<typestash> is non-null, the name is for a typed lexical, and this
566 identifies the type.  If I<ourstash> is non-null, it's a lexical reference
567 to a package variable, and this identifies the package.  The following
568 flags can be OR'ed together:
569
570     padadd_OUR          redundantly specifies if it's a package var
571     padadd_STATE        variable will retain value persistently
572     padadd_NO_DUP_CHECK skip check for lexical shadowing
573
574 =cut
575 */
576
577 PADOFFSET
578 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
579                 U32 flags, HV *typestash, HV *ourstash)
580 {
581     dVAR;
582     PADOFFSET offset;
583     SV *namesv;
584     bool is_utf8;
585
586     PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
587
588     if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
589         Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
590                    (UV)flags);
591
592     namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
593     
594     if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
595         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
596     }
597
598     sv_setpvn(namesv, namepv, namelen);
599
600     if (is_utf8) {
601         flags |= padadd_UTF8_NAME;
602         SvUTF8_on(namesv);
603     }
604     else
605         flags &= ~padadd_UTF8_NAME;
606
607     if ((flags & padadd_NO_DUP_CHECK) == 0) {
608         /* check for duplicate declaration */
609         pad_check_dup(namesv, flags & padadd_OUR, ourstash);
610     }
611
612     offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
613
614     /* not yet introduced */
615     COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
616     COP_SEQ_RANGE_HIGH_set(namesv, 0);
617
618     if (!PL_min_intro_pending)
619         PL_min_intro_pending = offset;
620     PL_max_intro_pending = offset;
621     /* if it's not a simple scalar, replace with an AV or HV */
622     assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
623     assert(SvREFCNT(PL_curpad[offset]) == 1);
624     if (namelen != 0 && *namepv == '@')
625         sv_upgrade(PL_curpad[offset], SVt_PVAV);
626     else if (namelen != 0 && *namepv == '%')
627         sv_upgrade(PL_curpad[offset], SVt_PVHV);
628     assert(SvPADMY(PL_curpad[offset]));
629     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
630                            "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
631                            (long)offset, SvPVX(namesv),
632                            PTR2UV(PL_curpad[offset])));
633
634     return offset;
635 }
636
637 /*
638 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
639
640 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
641 instead of a string/length pair.
642
643 =cut
644 */
645
646 PADOFFSET
647 Perl_pad_add_name_pv(pTHX_ const char *name,
648                      const U32 flags, HV *typestash, HV *ourstash)
649 {
650     PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
651     return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
652 }
653
654 /*
655 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
656
657 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
658 of an SV instead of a string/length pair.
659
660 =cut
661 */
662
663 PADOFFSET
664 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
665 {
666     char *namepv;
667     STRLEN namelen;
668     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
669     namepv = SvPV(name, namelen);
670     if (SvUTF8(name))
671         flags |= padadd_UTF8_NAME;
672     return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
673 }
674
675 /*
676 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
677
678 Allocates a place in the currently-compiling pad,
679 returning the offset of the allocated pad slot.
680 No name is initially attached to the pad slot.
681 I<tmptype> is a set of flags indicating the kind of pad entry required,
682 which will be set in the value SV for the allocated pad entry:
683
684     SVs_PADMY    named lexical variable ("my", "our", "state")
685     SVs_PADTMP   unnamed temporary store
686
687 I<optype> should be an opcode indicating the type of operation that the
688 pad entry is to support.  This doesn't affect operational semantics,
689 but is used for debugging.
690
691 =cut
692 */
693
694 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
695  * or at least rationalise ??? */
696
697 PADOFFSET
698 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
699 {
700     dVAR;
701     SV *sv;
702     I32 retval;
703
704     PERL_UNUSED_ARG(optype);
705     ASSERT_CURPAD_ACTIVE("pad_alloc");
706
707     if (AvARRAY(PL_comppad) != PL_curpad)
708         Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
709                    AvARRAY(PL_comppad), PL_curpad);
710     if (PL_pad_reset_pending)
711         pad_reset();
712     if (tmptype & SVs_PADMY) {
713         /* For a my, simply push a null SV onto the end of PL_comppad. */
714         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
715         retval = AvFILLp(PL_comppad);
716     }
717     else {
718         /* For a tmp, scan the pad from PL_padix upwards
719          * for a slot which has no name and no active value.
720          */
721         SV * const * const names = AvARRAY(PL_comppad_name);
722         const SSize_t names_fill = AvFILLp(PL_comppad_name);
723         for (;;) {
724             /*
725              * "foreach" index vars temporarily become aliases to non-"my"
726              * values.  Thus we must skip, not just pad values that are
727              * marked as current pad values, but also those with names.
728              */
729             /* HVDS why copy to sv here? we don't seem to use it */
730             if (++PL_padix <= names_fill &&
731                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
732                 continue;
733             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
734             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
735                 !IS_PADGV(sv) && !IS_PADCONST(sv))
736                 break;
737         }
738         retval = PL_padix;
739     }
740     SvFLAGS(sv) |= tmptype;
741     PL_curpad = AvARRAY(PL_comppad);
742
743     DEBUG_X(PerlIO_printf(Perl_debug_log,
744           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
745           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
746           PL_op_name[optype]));
747 #ifdef DEBUG_LEAKING_SCALARS
748     sv->sv_debug_optype = optype;
749     sv->sv_debug_inpad = 1;
750 #endif
751     return (PADOFFSET)retval;
752 }
753
754 /*
755 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
756
757 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
758 for an anonymous function that is lexically scoped inside the
759 currently-compiling function.
760 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
761 to the outer scope is weakened to avoid a reference loop.
762
763 I<optype> should be an opcode indicating the type of operation that the
764 pad entry is to support.  This doesn't affect operational semantics,
765 but is used for debugging.
766
767 =cut
768 */
769
770 PADOFFSET
771 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
772 {
773     dVAR;
774     PADOFFSET ix;
775     SV* const name = newSV_type(SVt_PVNV);
776
777     PERL_ARGS_ASSERT_PAD_ADD_ANON;
778
779     pad_peg("add_anon");
780     sv_setpvs(name, "&");
781     /* These two aren't used; just make sure they're not equal to
782      * PERL_PADSEQ_INTRO */
783     COP_SEQ_RANGE_LOW_set(name, 0);
784     COP_SEQ_RANGE_HIGH_set(name, 0);
785     ix = pad_alloc(optype, SVs_PADMY);
786     av_store(PL_comppad_name, ix, name);
787     /* XXX DAPM use PL_curpad[] ? */
788     if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
789         av_store(PL_comppad, ix, (SV*)func);
790     else {
791         SV *rv = newRV_inc((SV *)func);
792         sv_rvweaken(rv);
793         assert (SvTYPE(func) == SVt_PVFM);
794         av_store(PL_comppad, ix, rv);
795     }
796     SvPADMY_on((SV*)func);
797
798     /* to avoid ref loops, we never have parent + child referencing each
799      * other simultaneously */
800     if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
801         assert(!CvWEAKOUTSIDE(func));
802         CvWEAKOUTSIDE_on(func);
803         SvREFCNT_dec(CvOUTSIDE(func));
804     }
805     return ix;
806 }
807
808 /*
809 =for apidoc pad_check_dup
810
811 Check for duplicate declarations: report any of:
812
813      * a my in the current scope with the same name;
814      * an our (anywhere in the pad) with the same name and the
815        same stash as C<ourstash>
816
817 C<is_our> indicates that the name to check is an 'our' declaration.
818
819 =cut
820 */
821
822 STATIC void
823 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
824 {
825     dVAR;
826     SV          **svp;
827     PADOFFSET   top, off;
828     const U32   is_our = flags & padadd_OUR;
829
830     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
831
832     ASSERT_CURPAD_ACTIVE("pad_check_dup");
833
834     assert((flags & ~padadd_OUR) == 0);
835
836     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
837         return; /* nothing to check */
838
839     svp = AvARRAY(PL_comppad_name);
840     top = AvFILLp(PL_comppad_name);
841     /* check the current scope */
842     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
843      * type ? */
844     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
845         SV * const sv = svp[off];
846         if (sv
847             && sv != &PL_sv_undef
848             && !SvFAKE(sv)
849             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
850                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
851             && sv_eq(name, sv))
852         {
853             if (is_our && (SvPAD_OUR(sv)))
854                 break; /* "our" masking "our" */
855             Perl_warner(aTHX_ packWARN(WARN_MISC),
856                 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
857                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
858                 sv,
859                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
860                     ? "scope" : "statement"));
861             --off;
862             break;
863         }
864     }
865     /* check the rest of the pad */
866     if (is_our) {
867         while (off > 0) {
868             SV * const sv = svp[off];
869             if (sv
870                 && sv != &PL_sv_undef
871                 && !SvFAKE(sv)
872                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
873                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
874                 && SvOURSTASH(sv) == ourstash
875                 && sv_eq(name, sv))
876             {
877                 Perl_warner(aTHX_ packWARN(WARN_MISC),
878                     "\"our\" variable %"SVf" redeclared", sv);
879                 if ((I32)off <= PL_comppad_name_floor)
880                     Perl_warner(aTHX_ packWARN(WARN_MISC),
881                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
882                 break;
883             }
884             --off;
885         }
886     }
887 }
888
889
890 /*
891 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
892
893 Given the name of a lexical variable, find its position in the
894 currently-compiling pad.
895 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
896 I<flags> is reserved and must be zero.
897 If it is not in the current pad but appears in the pad of any lexically
898 enclosing scope, then a pseudo-entry for it is added in the current pad.
899 Returns the offset in the current pad,
900 or C<NOT_IN_PAD> if no such lexical is in scope.
901
902 =cut
903 */
904
905 PADOFFSET
906 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
907 {
908     dVAR;
909     SV *out_sv;
910     int out_flags;
911     I32 offset;
912     const AV *nameav;
913     SV **name_svp;
914
915     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
916
917     pad_peg("pad_findmy_pvn");
918
919     if (flags & ~padadd_UTF8_NAME)
920         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
921                    (UV)flags);
922
923     if (flags & padadd_UTF8_NAME) {
924         bool is_utf8 = TRUE;
925         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
926
927         if (is_utf8)
928             flags |= padadd_UTF8_NAME;
929         else
930             flags &= ~padadd_UTF8_NAME;
931     }
932
933     offset = pad_findlex(namepv, namelen, flags,
934                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
935     if ((PADOFFSET)offset != NOT_IN_PAD) 
936         return offset;
937
938     /* look for an our that's being introduced; this allows
939      *    our $foo = 0 unless defined $foo;
940      * to not give a warning. (Yes, this is a hack) */
941
942     nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
943     name_svp = AvARRAY(nameav);
944     for (offset = AvFILLp(nameav); offset > 0; offset--) {
945         const SV * const namesv = name_svp[offset];
946         if (namesv && namesv != &PL_sv_undef
947             && !SvFAKE(namesv)
948             && (SvPAD_OUR(namesv))
949             && SvCUR(namesv) == namelen
950             && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
951                                 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
952             && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
953         )
954             return offset;
955     }
956     return NOT_IN_PAD;
957 }
958
959 /*
960 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
961
962 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
963 instead of a string/length pair.
964
965 =cut
966 */
967
968 PADOFFSET
969 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
970 {
971     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
972     return pad_findmy_pvn(name, strlen(name), flags);
973 }
974
975 /*
976 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
977
978 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
979 of an SV instead of a string/length pair.
980
981 =cut
982 */
983
984 PADOFFSET
985 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
986 {
987     char *namepv;
988     STRLEN namelen;
989     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
990     namepv = SvPV(name, namelen);
991     if (SvUTF8(name))
992         flags |= padadd_UTF8_NAME;
993     return pad_findmy_pvn(namepv, namelen, flags);
994 }
995
996 /*
997 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
998
999 Find the position of the lexical C<$_> in the pad of the
1000 currently-executing function.  Returns the offset in the current pad,
1001 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1002 the global one should be used instead).
1003 L</find_rundefsv> is likely to be more convenient.
1004
1005 =cut
1006 */
1007
1008 PADOFFSET
1009 Perl_find_rundefsvoffset(pTHX)
1010 {
1011     dVAR;
1012     SV *out_sv;
1013     int out_flags;
1014     return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1015             NULL, &out_sv, &out_flags);
1016 }
1017
1018 /*
1019 =for apidoc Am|SV *|find_rundefsv
1020
1021 Find and return the variable that is named C<$_> in the lexical scope
1022 of the currently-executing function.  This may be a lexical C<$_>,
1023 or will otherwise be the global one.
1024
1025 =cut
1026 */
1027
1028 SV *
1029 Perl_find_rundefsv(pTHX)
1030 {
1031     SV *namesv;
1032     int flags;
1033     PADOFFSET po;
1034
1035     po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1036             NULL, &namesv, &flags);
1037
1038     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1039         return DEFSV;
1040
1041     return PAD_SVl(po);
1042 }
1043
1044 SV *
1045 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1046 {
1047     SV *namesv;
1048     int flags;
1049     PADOFFSET po;
1050
1051     PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1052
1053     po = pad_findlex("$_", 2, 0, cv, seq, 1,
1054             NULL, &namesv, &flags);
1055
1056     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1057         return DEFSV;
1058
1059     return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1060 }
1061
1062 /*
1063 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1064
1065 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1066 in the inner pads if it's found in an outer one.
1067
1068 Returns the offset in the bottom pad of the lex or the fake lex.
1069 cv is the CV in which to start the search, and seq is the current cop_seq
1070 to match against. If warn is true, print appropriate warnings.  The out_*
1071 vars return values, and so are pointers to where the returned values
1072 should be stored. out_capture, if non-null, requests that the innermost
1073 instance of the lexical is captured; out_name_sv is set to the innermost
1074 matched namesv or fake namesv; out_flags returns the flags normally
1075 associated with the IVX field of a fake namesv.
1076
1077 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1078 then comes back down, adding fake entries as it goes. It has to be this way
1079 because fake namesvs in anon protoypes have to store in xlow the index into
1080 the parent pad.
1081
1082 =cut
1083 */
1084
1085 /* the CV has finished being compiled. This is not a sufficient test for
1086  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1087 #define CvCOMPILED(cv)  CvROOT(cv)
1088
1089 /* the CV does late binding of its lexicals */
1090 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1091
1092
1093 STATIC PADOFFSET
1094 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1095         int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1096 {
1097     dVAR;
1098     I32 offset, new_offset;
1099     SV *new_capture;
1100     SV **new_capturep;
1101     const AV * const padlist = CvPADLIST(cv);
1102
1103     PERL_ARGS_ASSERT_PAD_FINDLEX;
1104
1105     if (flags & ~padadd_UTF8_NAME)
1106         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1107                    (UV)flags);
1108
1109     *out_flags = 0;
1110
1111     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1112         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1113                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1114         out_capture ? " capturing" : "" ));
1115
1116     /* first, search this pad */
1117
1118     if (padlist) { /* not an undef CV */
1119         I32 fake_offset = 0;
1120         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1121         SV * const * const name_svp = AvARRAY(nameav);
1122
1123         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1124             const SV * const namesv = name_svp[offset];
1125             if (namesv && namesv != &PL_sv_undef
1126                     && SvCUR(namesv) == namelen
1127                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1128                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1129             {
1130                 if (SvFAKE(namesv)) {
1131                     fake_offset = offset; /* in case we don't find a real one */
1132                     continue;
1133                 }
1134                 /* is seq within the range _LOW to _HIGH ?
1135                  * This is complicated by the fact that PL_cop_seqmax
1136                  * may have wrapped around at some point */
1137                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1138                     continue; /* not yet introduced */
1139
1140                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1141                     /* in compiling scope */
1142                     if (
1143                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1144                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1145                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1146                     )
1147                        break;
1148                 }
1149                 else if (
1150                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1151                     ?
1152                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1153                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1154
1155                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1156                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1157                 )
1158                 break;
1159             }
1160         }
1161
1162         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1163             if (offset > 0) { /* not fake */
1164                 fake_offset = 0;
1165                 *out_name_sv = name_svp[offset]; /* return the namesv */
1166
1167                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1168                  * instances. For now, we just test !CvUNIQUE(cv), but
1169                  * ideally, we should detect my's declared within loops
1170                  * etc - this would allow a wider range of 'not stayed
1171                  * shared' warnings. We also treated already-compiled
1172                  * lexes as not multi as viewed from evals. */
1173
1174                 *out_flags = CvANON(cv) ?
1175                         PAD_FAKELEX_ANON :
1176                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1177                                 ? PAD_FAKELEX_MULTI : 0;
1178
1179                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1180                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1181                     PTR2UV(cv), (long)offset,
1182                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1183                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1184             }
1185             else { /* fake match */
1186                 offset = fake_offset;
1187                 *out_name_sv = name_svp[offset]; /* return the namesv */
1188                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1189                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1190                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1191                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1192                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1193                 ));
1194             }
1195
1196             /* return the lex? */
1197
1198             if (out_capture) {
1199
1200                 /* our ? */
1201                 if (SvPAD_OUR(*out_name_sv)) {
1202                     *out_capture = NULL;
1203                     return offset;
1204                 }
1205
1206                 /* trying to capture from an anon prototype? */
1207                 if (CvCOMPILED(cv)
1208                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1209                         : *out_flags & PAD_FAKELEX_ANON)
1210                 {
1211                     if (warn)
1212                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1213                                        "Variable \"%"SVf"\" is not available",
1214                                        newSVpvn_flags(namepv, namelen,
1215                                            SVs_TEMP |
1216                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1217
1218                     *out_capture = NULL;
1219                 }
1220
1221                 /* real value */
1222                 else {
1223                     int newwarn = warn;
1224                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1225                          && !SvPAD_STATE(name_svp[offset])
1226                          && warn && ckWARN(WARN_CLOSURE)) {
1227                         newwarn = 0;
1228                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1229                             "Variable \"%"SVf"\" will not stay shared",
1230                             newSVpvn_flags(namepv, namelen,
1231                                 SVs_TEMP |
1232                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1233                     }
1234
1235                     if (fake_offset && CvANON(cv)
1236                             && CvCLONE(cv) &&!CvCLONED(cv))
1237                     {
1238                         SV *n;
1239                         /* not yet caught - look further up */
1240                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1241                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1242                             PTR2UV(cv)));
1243                         n = *out_name_sv;
1244                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1245                             CvOUTSIDE_SEQ(cv),
1246                             newwarn, out_capture, out_name_sv, out_flags);
1247                         *out_name_sv = n;
1248                         return offset;
1249                     }
1250
1251                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1252                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1253                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1254                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1255                         PTR2UV(cv), PTR2UV(*out_capture)));
1256
1257                     if (SvPADSTALE(*out_capture)
1258                         && !SvPAD_STATE(name_svp[offset]))
1259                     {
1260                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1261                                        "Variable \"%"SVf"\" is not available",
1262                                        newSVpvn_flags(namepv, namelen,
1263                                            SVs_TEMP |
1264                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1265                         *out_capture = NULL;
1266                     }
1267                 }
1268                 if (!*out_capture) {
1269                     if (namelen != 0 && *namepv == '@')
1270                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1271                     else if (namelen != 0 && *namepv == '%')
1272                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1273                     else
1274                         *out_capture = sv_newmortal();
1275                 }
1276             }
1277
1278             return offset;
1279         }
1280     }
1281
1282     /* it's not in this pad - try above */
1283
1284     if (!CvOUTSIDE(cv))
1285         return NOT_IN_PAD;
1286
1287     /* out_capture non-null means caller wants us to capture lex; in
1288      * addition we capture ourselves unless it's an ANON/format */
1289     new_capturep = out_capture ? out_capture :
1290                 CvLATE(cv) ? NULL : &new_capture;
1291
1292     offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1293                 new_capturep, out_name_sv, out_flags);
1294     if ((PADOFFSET)offset == NOT_IN_PAD)
1295         return NOT_IN_PAD;
1296
1297     /* found in an outer CV. Add appropriate fake entry to this pad */
1298
1299     /* don't add new fake entries (via eval) to CVs that we have already
1300      * finished compiling, or to undef CVs */
1301     if (CvCOMPILED(cv) || !padlist)
1302         return 0; /* this dummy (and invalid) value isnt used by the caller */
1303
1304     {
1305         /* This relies on sv_setsv_flags() upgrading the destination to the same
1306            type as the source, independent of the flags set, and on it being
1307            "good" and only copying flag bits and pointers that it understands.
1308         */
1309         SV *new_namesv = newSVsv(*out_name_sv);
1310         AV *  const ocomppad_name = PL_comppad_name;
1311         PAD * const ocomppad = PL_comppad;
1312         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1313         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1314         PL_curpad = AvARRAY(PL_comppad);
1315
1316         new_offset
1317             = pad_alloc_name(new_namesv,
1318                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1319                               SvPAD_TYPED(*out_name_sv)
1320                               ? SvSTASH(*out_name_sv) : NULL,
1321                               SvOURSTASH(*out_name_sv)
1322                               );
1323
1324         SvFAKE_on(new_namesv);
1325         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1326                                "Pad addname: %ld \"%.*s\" FAKE\n",
1327                                (long)new_offset,
1328                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1329         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1330
1331         PARENT_PAD_INDEX_set(new_namesv, 0);
1332         if (SvPAD_OUR(new_namesv)) {
1333             NOOP;   /* do nothing */
1334         }
1335         else if (CvLATE(cv)) {
1336             /* delayed creation - just note the offset within parent pad */
1337             PARENT_PAD_INDEX_set(new_namesv, offset);
1338             CvCLONE_on(cv);
1339         }
1340         else {
1341             /* immediate creation - capture outer value right now */
1342             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1343             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1344                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1345                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1346         }
1347         *out_name_sv = new_namesv;
1348         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1349
1350         PL_comppad_name = ocomppad_name;
1351         PL_comppad = ocomppad;
1352         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1353     }
1354     return new_offset;
1355 }
1356
1357 #ifdef DEBUGGING
1358
1359 /*
1360 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1361
1362 Get the value at offset I<po> in the current (compiling or executing) pad.
1363 Use macro PAD_SV instead of calling this function directly.
1364
1365 =cut
1366 */
1367
1368 SV *
1369 Perl_pad_sv(pTHX_ PADOFFSET po)
1370 {
1371     dVAR;
1372     ASSERT_CURPAD_ACTIVE("pad_sv");
1373
1374     if (!po)
1375         Perl_croak(aTHX_ "panic: pad_sv po");
1376     DEBUG_X(PerlIO_printf(Perl_debug_log,
1377         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1378         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1379     );
1380     return PL_curpad[po];
1381 }
1382
1383 /*
1384 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1385
1386 Set the value at offset I<po> in the current (compiling or executing) pad.
1387 Use the macro PAD_SETSV() rather than calling this function directly.
1388
1389 =cut
1390 */
1391
1392 void
1393 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1394 {
1395     dVAR;
1396
1397     PERL_ARGS_ASSERT_PAD_SETSV;
1398
1399     ASSERT_CURPAD_ACTIVE("pad_setsv");
1400
1401     DEBUG_X(PerlIO_printf(Perl_debug_log,
1402         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1403         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1404     );
1405     PL_curpad[po] = sv;
1406 }
1407
1408 #endif /* DEBUGGING */
1409
1410 /*
1411 =for apidoc m|void|pad_block_start|int full
1412
1413 Update the pad compilation state variables on entry to a new block
1414
1415 =cut
1416 */
1417
1418 /* XXX DAPM perhaps:
1419  *      - integrate this in general state-saving routine ???
1420  *      - combine with the state-saving going on in pad_new ???
1421  *      - introduce a new SAVE type that does all this in one go ?
1422  */
1423
1424 void
1425 Perl_pad_block_start(pTHX_ int full)
1426 {
1427     dVAR;
1428     ASSERT_CURPAD_ACTIVE("pad_block_start");
1429     SAVEI32(PL_comppad_name_floor);
1430     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1431     if (full)
1432         PL_comppad_name_fill = PL_comppad_name_floor;
1433     if (PL_comppad_name_floor < 0)
1434         PL_comppad_name_floor = 0;
1435     SAVEI32(PL_min_intro_pending);
1436     SAVEI32(PL_max_intro_pending);
1437     PL_min_intro_pending = 0;
1438     SAVEI32(PL_comppad_name_fill);
1439     SAVEI32(PL_padix_floor);
1440     PL_padix_floor = PL_padix;
1441     PL_pad_reset_pending = FALSE;
1442 }
1443
1444 /*
1445 =for apidoc m|U32|intro_my
1446
1447 "Introduce" my variables to visible status.
1448
1449 =cut
1450 */
1451
1452 U32
1453 Perl_intro_my(pTHX)
1454 {
1455     dVAR;
1456     SV **svp;
1457     I32 i;
1458     U32 seq;
1459
1460     ASSERT_CURPAD_ACTIVE("intro_my");
1461     if (! PL_min_intro_pending)
1462         return PL_cop_seqmax;
1463
1464     svp = AvARRAY(PL_comppad_name);
1465     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1466         SV * const sv = svp[i];
1467
1468         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1469             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1470         {
1471             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1472             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1473             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1474                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1475                 (long)i, SvPVX_const(sv),
1476                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1477                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1478             );
1479         }
1480     }
1481     seq = PL_cop_seqmax;
1482     PL_cop_seqmax++;
1483     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1484         PL_cop_seqmax++;
1485     PL_min_intro_pending = 0;
1486     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1487     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1488                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1489
1490     return seq;
1491 }
1492
1493 /*
1494 =for apidoc m|void|pad_leavemy
1495
1496 Cleanup at end of scope during compilation: set the max seq number for
1497 lexicals in this scope and warn of any lexicals that never got introduced.
1498
1499 =cut
1500 */
1501
1502 void
1503 Perl_pad_leavemy(pTHX)
1504 {
1505     dVAR;
1506     I32 off;
1507     SV * const * const svp = AvARRAY(PL_comppad_name);
1508
1509     PL_pad_reset_pending = FALSE;
1510
1511     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1512     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1513         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1514             const SV * const sv = svp[off];
1515             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1516                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1517                                  "%"SVf" never introduced",
1518                                  SVfARG(sv));
1519         }
1520     }
1521     /* "Deintroduce" my variables that are leaving with this scope. */
1522     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1523         const SV * const sv = svp[off];
1524         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1525             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1526         {
1527             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1528             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1529                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1530                 (long)off, SvPVX_const(sv),
1531                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1532                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1533             );
1534         }
1535     }
1536     PL_cop_seqmax++;
1537     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1538         PL_cop_seqmax++;
1539     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1541 }
1542
1543 /*
1544 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1545
1546 Abandon the tmp in the current pad at offset po and replace with a
1547 new one.
1548
1549 =cut
1550 */
1551
1552 void
1553 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1554 {
1555     dVAR;
1556     ASSERT_CURPAD_LEGAL("pad_swipe");
1557     if (!PL_curpad)
1558         return;
1559     if (AvARRAY(PL_comppad) != PL_curpad)
1560         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1561                    AvARRAY(PL_comppad), PL_curpad);
1562     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1563         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1564                    (long)po, (long)AvFILLp(PL_comppad));
1565
1566     DEBUG_X(PerlIO_printf(Perl_debug_log,
1567                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1568                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1569
1570     if (PL_curpad[po])
1571         SvPADTMP_off(PL_curpad[po]);
1572     if (refadjust)
1573         SvREFCNT_dec(PL_curpad[po]);
1574
1575
1576     /* if pad tmps aren't shared between ops, then there's no need to
1577      * create a new tmp when an existing op is freed */
1578 #ifdef USE_BROKEN_PAD_RESET
1579     PL_curpad[po] = newSV(0);
1580     SvPADTMP_on(PL_curpad[po]);
1581 #else
1582     PL_curpad[po] = &PL_sv_undef;
1583 #endif
1584     if ((I32)po < PL_padix)
1585         PL_padix = po - 1;
1586 }
1587
1588 /*
1589 =for apidoc m|void|pad_reset
1590
1591 Mark all the current temporaries for reuse
1592
1593 =cut
1594 */
1595
1596 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1597  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1598  * on the stack by OPs that use them, there are several ways to get an alias
1599  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1600  * We avoid doing this until we can think of a Better Way.
1601  * GSAR 97-10-29 */
1602 static void
1603 S_pad_reset(pTHX)
1604 {
1605     dVAR;
1606 #ifdef USE_BROKEN_PAD_RESET
1607     if (AvARRAY(PL_comppad) != PL_curpad)
1608         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1609                    AvARRAY(PL_comppad), PL_curpad);
1610
1611     DEBUG_X(PerlIO_printf(Perl_debug_log,
1612             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1613             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1614                 (long)PL_padix, (long)PL_padix_floor
1615             )
1616     );
1617
1618     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1619         register I32 po;
1620         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1621             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1622                 SvPADTMP_off(PL_curpad[po]);
1623         }
1624         PL_padix = PL_padix_floor;
1625     }
1626 #endif
1627     PL_pad_reset_pending = FALSE;
1628 }
1629
1630 /*
1631 =for apidoc Amx|void|pad_tidy|padtidy_type type
1632
1633 Tidy up a pad at the end of compilation of the code to which it belongs.
1634 Jobs performed here are: remove most stuff from the pads of anonsub
1635 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1636 the kind of subroutine:
1637
1638     padtidy_SUB        ordinary subroutine
1639     padtidy_SUBCLONE   prototype for lexical closure
1640     padtidy_FORMAT     format
1641
1642 =cut
1643 */
1644
1645 /* XXX DAPM surely most of this stuff should be done properly
1646  * at the right time beforehand, rather than going around afterwards
1647  * cleaning up our mistakes ???
1648  */
1649
1650 void
1651 Perl_pad_tidy(pTHX_ padtidy_type type)
1652 {
1653     dVAR;
1654
1655     ASSERT_CURPAD_ACTIVE("pad_tidy");
1656
1657     /* If this CV has had any 'eval-capable' ops planted in it
1658      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1659      * anon prototypes in the chain of CVs should be marked as cloneable,
1660      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1661      * the right CvOUTSIDE.
1662      * If running with -d, *any* sub may potentially have an eval
1663      * executed within it.
1664      */
1665
1666     if (PL_cv_has_eval || PL_perldb) {
1667         const CV *cv;
1668         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1669             if (cv != PL_compcv && CvCOMPILED(cv))
1670                 break; /* no need to mark already-compiled code */
1671             if (CvANON(cv)) {
1672                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1673                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1674                 CvCLONE_on(cv);
1675                 CvHASEVAL_on(cv);
1676             }
1677         }
1678     }
1679
1680     /* extend curpad to match namepad */
1681     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1682         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1683
1684     if (type == padtidy_SUBCLONE) {
1685         SV * const * const namep = AvARRAY(PL_comppad_name);
1686         PADOFFSET ix;
1687
1688         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1689             SV *namesv;
1690
1691             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1692                 continue;
1693             /*
1694              * The only things that a clonable function needs in its
1695              * pad are anonymous subs.
1696              * The rest are created anew during cloning.
1697              */
1698             if (!((namesv = namep[ix]) != NULL &&
1699                   namesv != &PL_sv_undef &&
1700                    *SvPVX_const(namesv) == '&'))
1701             {
1702                 SvREFCNT_dec(PL_curpad[ix]);
1703                 PL_curpad[ix] = NULL;
1704             }
1705         }
1706     }
1707     else if (type == padtidy_SUB) {
1708         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1709         AV * const av = newAV();                        /* Will be @_ */
1710         av_store(PL_comppad, 0, MUTABLE_SV(av));
1711         AvREIFY_only(av);
1712     }
1713
1714     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1715         SV * const * const namep = AvARRAY(PL_comppad_name);
1716         PADOFFSET ix;
1717         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1718             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1719                 continue;
1720             if (!SvPADMY(PL_curpad[ix])) {
1721                 SvPADTMP_on(PL_curpad[ix]);
1722             } else if (!SvFAKE(namep[ix])) {
1723                 /* This is a work around for how the current implementation of
1724                    ?{ } blocks in regexps interacts with lexicals.
1725
1726                    One of our lexicals.
1727                    Can't do this on all lexicals, otherwise sub baz() won't
1728                    compile in
1729
1730                    my $foo;
1731
1732                    sub bar { ++$foo; }
1733
1734                    sub baz { ++$foo; }
1735
1736                    because completion of compiling &bar calling pad_tidy()
1737                    would cause (top level) $foo to be marked as stale, and
1738                    "no longer available".  */
1739                 SvPADSTALE_on(PL_curpad[ix]);
1740             }
1741         }
1742     }
1743     PL_curpad = AvARRAY(PL_comppad);
1744 }
1745
1746 /*
1747 =for apidoc m|void|pad_free|PADOFFSET po
1748
1749 Free the SV at offset po in the current pad.
1750
1751 =cut
1752 */
1753
1754 /* XXX DAPM integrate with pad_swipe ???? */
1755 void
1756 Perl_pad_free(pTHX_ PADOFFSET po)
1757 {
1758     dVAR;
1759     ASSERT_CURPAD_LEGAL("pad_free");
1760     if (!PL_curpad)
1761         return;
1762     if (AvARRAY(PL_comppad) != PL_curpad)
1763         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1764                    AvARRAY(PL_comppad), PL_curpad);
1765     if (!po)
1766         Perl_croak(aTHX_ "panic: pad_free po");
1767
1768     DEBUG_X(PerlIO_printf(Perl_debug_log,
1769             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1770             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1771     );
1772
1773     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1774         SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1775     }
1776     if ((I32)po < PL_padix)
1777         PL_padix = po - 1;
1778 }
1779
1780 /*
1781 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1782
1783 Dump the contents of a padlist
1784
1785 =cut
1786 */
1787
1788 void
1789 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1790 {
1791     dVAR;
1792     const AV *pad_name;
1793     const AV *pad;
1794     SV **pname;
1795     SV **ppad;
1796     I32 ix;
1797
1798     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1799
1800     if (!padlist) {
1801         return;
1802     }
1803     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1804     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1805     pname = AvARRAY(pad_name);
1806     ppad = AvARRAY(pad);
1807     Perl_dump_indent(aTHX_ level, file,
1808             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1809             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1810     );
1811
1812     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1813         const SV *namesv = pname[ix];
1814         if (namesv && namesv == &PL_sv_undef) {
1815             namesv = NULL;
1816         }
1817         if (namesv) {
1818             if (SvFAKE(namesv))
1819                 Perl_dump_indent(aTHX_ level+1, file,
1820                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1821                     (int) ix,
1822                     PTR2UV(ppad[ix]),
1823                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1824                     SvPVX_const(namesv),
1825                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1826                     (unsigned long)PARENT_PAD_INDEX(namesv)
1827
1828                 );
1829             else
1830                 Perl_dump_indent(aTHX_ level+1, file,
1831                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1832                     (int) ix,
1833                     PTR2UV(ppad[ix]),
1834                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1835                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1836                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1837                     SvPVX_const(namesv)
1838                 );
1839         }
1840         else if (full) {
1841             Perl_dump_indent(aTHX_ level+1, file,
1842                 "%2d. 0x%"UVxf"<%lu>\n",
1843                 (int) ix,
1844                 PTR2UV(ppad[ix]),
1845                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1846             );
1847         }
1848     }
1849 }
1850
1851 #ifdef DEBUGGING
1852
1853 /*
1854 =for apidoc m|void|cv_dump|CV *cv|const char *title
1855
1856 dump the contents of a CV
1857
1858 =cut
1859 */
1860
1861 STATIC void
1862 S_cv_dump(pTHX_ const CV *cv, const char *title)
1863 {
1864     dVAR;
1865     const CV * const outside = CvOUTSIDE(cv);
1866     AV* const padlist = CvPADLIST(cv);
1867
1868     PERL_ARGS_ASSERT_CV_DUMP;
1869
1870     PerlIO_printf(Perl_debug_log,
1871                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1872                   title,
1873                   PTR2UV(cv),
1874                   (CvANON(cv) ? "ANON"
1875                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1876                    : (cv == PL_main_cv) ? "MAIN"
1877                    : CvUNIQUE(cv) ? "UNIQUE"
1878                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1879                   PTR2UV(outside),
1880                   (!outside ? "null"
1881                    : CvANON(outside) ? "ANON"
1882                    : (outside == PL_main_cv) ? "MAIN"
1883                    : CvUNIQUE(outside) ? "UNIQUE"
1884                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1885
1886     PerlIO_printf(Perl_debug_log,
1887                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1888     do_dump_pad(1, Perl_debug_log, padlist, 1);
1889 }
1890
1891 #endif /* DEBUGGING */
1892
1893 /*
1894 =for apidoc Am|CV *|cv_clone|CV *proto
1895
1896 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1897 of the function: its code, pad structure, and other attributes.
1898 The prototype is combined with a capture of outer lexicals to which the
1899 code refers, which are taken from the currently-executing instance of
1900 the immediately surrounding code.
1901
1902 =cut
1903 */
1904
1905 CV *
1906 Perl_cv_clone(pTHX_ CV *proto)
1907 {
1908     dVAR;
1909     I32 ix;
1910     AV* const protopadlist = CvPADLIST(proto);
1911     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1912     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1913     SV** const pname = AvARRAY(protopad_name);
1914     SV** const ppad = AvARRAY(protopad);
1915     const I32 fname = AvFILLp(protopad_name);
1916     const I32 fpad = AvFILLp(protopad);
1917     CV* cv;
1918     SV** outpad;
1919     CV* outside;
1920     long depth;
1921
1922     PERL_ARGS_ASSERT_CV_CLONE;
1923
1924     assert(!CvUNIQUE(proto));
1925
1926     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1927      * to a prototype; we instead want the cloned parent who called us.
1928      * Note that in general for formats, CvOUTSIDE != find_runcv; formats
1929      * inside closures, however, only work if CvOUTSIDE == find_runcv.
1930      */
1931
1932     outside = CvOUTSIDE(proto);
1933     if (!outside || (CvCLONE(outside) && ! CvCLONED(outside)))
1934         outside = find_runcv(NULL);
1935     if (SvTYPE(proto) == SVt_PVFM
1936      && CvROOT(outside) != CvROOT(CvOUTSIDE(proto)))
1937         outside = CvOUTSIDE(proto);
1938     depth = CvDEPTH(outside);
1939     assert(depth || SvTYPE(proto) == SVt_PVFM);
1940     if (!depth)
1941         depth = 1;
1942     assert(CvPADLIST(outside));
1943
1944     ENTER;
1945     SAVESPTR(PL_compcv);
1946
1947     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1948     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1949                                     |CVf_SLABBED);
1950     CvCLONED_on(cv);
1951
1952     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1953                                            : CvFILE(proto);
1954     CvGV_set(cv,CvGV(proto));
1955     CvSTASH_set(cv, CvSTASH(proto));
1956     OP_REFCNT_LOCK;
1957     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1958     OP_REFCNT_UNLOCK;
1959     CvSTART(cv)         = CvSTART(proto);
1960     if (CvHASEVAL(cv))
1961         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1962     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1963
1964     if (SvPOK(proto))
1965         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1966     if (SvMAGIC(proto))
1967         mg_copy((SV *)proto, (SV *)cv, 0, 0);
1968
1969     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1970
1971     av_fill(PL_comppad, fpad);
1972     for (ix = fname; ix > 0; ix--)
1973         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1974
1975     PL_curpad = AvARRAY(PL_comppad);
1976
1977     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1978
1979     for (ix = fpad; ix > 0; ix--) {
1980         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1981         SV *sv = NULL;
1982         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1983             if (SvFAKE(namesv)) {   /* lexical from outside? */
1984                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1985                 /* formats may have an inactive parent,
1986                    while my $x if $false can leave an active var marked as
1987                    stale. And state vars are always available */
1988                 if (!sv || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
1989                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1990                                    "Variable \"%"SVf"\" is not available", namesv);
1991                     sv = NULL;
1992                 }
1993                 else 
1994                     SvREFCNT_inc_simple_void_NN(sv);
1995             }
1996             if (!sv) {
1997                 const char sigil = SvPVX_const(namesv)[0];
1998                 if (sigil == '&')
1999                     sv = SvREFCNT_inc(ppad[ix]);
2000                 else if (sigil == '@')
2001                     sv = MUTABLE_SV(newAV());
2002                 else if (sigil == '%')
2003                     sv = MUTABLE_SV(newHV());
2004                 else
2005                     sv = newSV(0);
2006                 SvPADMY_on(sv);
2007                 /* reset the 'assign only once' flag on each state var */
2008                 if (SvPAD_STATE(namesv))
2009                     SvPADSTALE_on(sv);
2010             }
2011         }
2012         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2013             sv = SvREFCNT_inc_NN(ppad[ix]);
2014         }
2015         else {
2016             sv = newSV(0);
2017             SvPADTMP_on(sv);
2018         }
2019         PL_curpad[ix] = sv;
2020     }
2021
2022     DEBUG_Xv(
2023         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2024         cv_dump(outside, "Outside");
2025         cv_dump(proto,   "Proto");
2026         cv_dump(cv,      "To");
2027     );
2028
2029     LEAVE;
2030
2031     if (CvCONST(cv)) {
2032         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2033          * The prototype was marked as a candiate for const-ization,
2034          * so try to grab the current const value, and if successful,
2035          * turn into a const sub:
2036          */
2037         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2038         if (const_sv) {
2039             SvREFCNT_dec(cv);
2040             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2041         }
2042         else {
2043             CvCONST_off(cv);
2044         }
2045     }
2046
2047     return cv;
2048 }
2049
2050 /*
2051 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2052
2053 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2054 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2055 moved to a pre-existing CV struct.
2056
2057 =cut
2058 */
2059
2060 void
2061 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2062 {
2063     dVAR;
2064     I32 ix;
2065     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2066     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2067     SV ** const namepad = AvARRAY(comppad_name);
2068     SV ** const curpad = AvARRAY(comppad);
2069
2070     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2071     PERL_UNUSED_ARG(old_cv);
2072
2073     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2074         const SV * const namesv = namepad[ix];
2075         if (namesv && namesv != &PL_sv_undef
2076             && *SvPVX_const(namesv) == '&')
2077         {
2078           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2079             CV * const innercv = MUTABLE_CV(curpad[ix]);
2080             assert(CvWEAKOUTSIDE(innercv));
2081             assert(CvOUTSIDE(innercv) == old_cv);
2082             CvOUTSIDE(innercv) = new_cv;
2083           }
2084           else { /* format reference */
2085             SV * const rv = curpad[ix];
2086             CV *innercv;
2087             if (!SvOK(rv)) continue;
2088             assert(SvROK(rv));
2089             assert(SvWEAKREF(rv));
2090             innercv = (CV *)SvRV(rv);
2091             assert(!CvWEAKOUTSIDE(innercv));
2092             SvREFCNT_dec(CvOUTSIDE(innercv));
2093             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2094           }
2095         }
2096     }
2097 }
2098
2099 /*
2100 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2101
2102 Push a new pad frame onto the padlist, unless there's already a pad at
2103 this depth, in which case don't bother creating a new one.  Then give
2104 the new pad an @_ in slot zero.
2105
2106 =cut
2107 */
2108
2109 void
2110 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2111 {
2112     dVAR;
2113
2114     PERL_ARGS_ASSERT_PAD_PUSH;
2115
2116     if (depth > AvFILLp(padlist)) {
2117         SV** const svp = AvARRAY(padlist);
2118         AV* const newpad = newAV();
2119         SV** const oldpad = AvARRAY(svp[depth-1]);
2120         I32 ix = AvFILLp((const AV *)svp[1]);
2121         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2122         SV** const names = AvARRAY(svp[0]);
2123         AV *av;
2124
2125         for ( ;ix > 0; ix--) {
2126             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2127                 const char sigil = SvPVX_const(names[ix])[0];
2128                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2129                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2130                         || sigil == '&')
2131                 {
2132                     /* outer lexical or anon code */
2133                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2134                 }
2135                 else {          /* our own lexical */
2136                     SV *sv; 
2137                     if (sigil == '@')
2138                         sv = MUTABLE_SV(newAV());
2139                     else if (sigil == '%')
2140                         sv = MUTABLE_SV(newHV());
2141                     else
2142                         sv = newSV(0);
2143                     av_store(newpad, ix, sv);
2144                     SvPADMY_on(sv);
2145                 }
2146             }
2147             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2148                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2149             }
2150             else {
2151                 /* save temporaries on recursion? */
2152                 SV * const sv = newSV(0);
2153                 av_store(newpad, ix, sv);
2154                 SvPADTMP_on(sv);
2155             }
2156         }
2157         av = newAV();
2158         av_store(newpad, 0, MUTABLE_SV(av));
2159         AvREIFY_only(av);
2160
2161         av_store(padlist, depth, MUTABLE_SV(newpad));
2162         AvFILLp(padlist) = depth;
2163     }
2164 }
2165
2166 /*
2167 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2168
2169 Looks up the type of the lexical variable at position I<po> in the
2170 currently-compiling pad.  If the variable is typed, the stash of the
2171 class to which it is typed is returned.  If not, C<NULL> is returned.
2172
2173 =cut
2174 */
2175
2176 HV *
2177 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2178 {
2179     dVAR;
2180     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2181     if ( SvPAD_TYPED(*av) ) {
2182         return SvSTASH(*av);
2183     }
2184     return NULL;
2185 }
2186
2187 #if defined(USE_ITHREADS)
2188
2189 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2190
2191 /*
2192 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2193
2194 Duplicates a pad.
2195
2196 =cut
2197 */
2198
2199 AV *
2200 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2201 {
2202     AV *dstpad;
2203     PERL_ARGS_ASSERT_PADLIST_DUP;
2204
2205     if (!srcpad)
2206         return NULL;
2207
2208     if (param->flags & CLONEf_COPY_STACKS
2209         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2210         dstpad = av_dup_inc(srcpad, param);
2211         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2212     } else {
2213         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2214            to build anything other than the first level of pads.  */
2215
2216         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2217         AV *pad1;
2218         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2219         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2220         SV **oldpad = AvARRAY(srcpad1);
2221         SV **names;
2222         SV **pad1a;
2223         AV *args;
2224         /* Look for it in the table first, as the padlist may have ended up
2225            as an element of @DB::args (or theoretically even @_), so it may
2226            may have been cloned already. */
2227         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2228
2229         if (dstpad)
2230             return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2231
2232         dstpad = newAV();
2233         ptr_table_store(PL_ptr_table, srcpad, dstpad);
2234         av_extend(dstpad, 1);
2235         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2236         names = AvARRAY(AvARRAY(dstpad)[0]);
2237
2238         pad1 = newAV();
2239
2240         av_extend(pad1, ix);
2241         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2242         pad1a = AvARRAY(pad1);
2243         AvFILLp(dstpad) = 1;
2244
2245         if (ix > -1) {
2246             AvFILLp(pad1) = ix;
2247
2248             for ( ;ix > 0; ix--) {
2249                 if (!oldpad[ix]) {
2250                     pad1a[ix] = NULL;
2251                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2252                     const char sigil = SvPVX_const(names[ix])[0];
2253                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2254                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2255                         || sigil == '&')
2256                         {
2257                             /* outer lexical or anon code */
2258                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2259                         }
2260                     else {              /* our own lexical */
2261                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2262                             /* This is a work around for how the current
2263                                implementation of ?{ } blocks in regexps
2264                                interacts with lexicals.  */
2265                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2266                         } else {
2267                             SV *sv; 
2268                             
2269                             if (sigil == '@')
2270                                 sv = MUTABLE_SV(newAV());
2271                             else if (sigil == '%')
2272                                 sv = MUTABLE_SV(newHV());
2273                             else
2274                                 sv = newSV(0);
2275                             pad1a[ix] = sv;
2276                             SvPADMY_on(sv);
2277                         }
2278                     }
2279                 }
2280                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2281                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2282                 }
2283                 else {
2284                     /* save temporaries on recursion? */
2285                     SV * const sv = newSV(0);
2286                     pad1a[ix] = sv;
2287
2288                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2289                        FIXTHAT before merging this branch.
2290                        (And I know how to) */
2291                     if (SvPADMY(oldpad[ix]))
2292                         SvPADMY_on(sv);
2293                     else
2294                         SvPADTMP_on(sv);
2295                 }
2296             }
2297
2298             if (oldpad[0]) {
2299                 args = newAV();                 /* Will be @_ */
2300                 AvREIFY_only(args);
2301                 pad1a[0] = (SV *)args;
2302             }
2303         }
2304     }
2305
2306     return dstpad;
2307 }
2308
2309 #endif /* USE_ITHREADS */
2310
2311 /*
2312  * Local variables:
2313  * c-indentation-style: bsd
2314  * c-basic-offset: 4
2315  * indent-tabs-mode: nil
2316  * End:
2317  *
2318  * ex: set ts=8 sts=4 sw=4 et:
2319  */