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