The space computation for hexfp was overovershooting.
[perl.git] / pad.c
1 /*    pad.c
2  *
3  *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  */
9
10 /*
11  *  'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12  *   might say, among those queer Bucklanders, being brought up anyhow in
13  *   Brandy Hall.  A regular warren, by all accounts.  Old Master Gorbadoc
14  *   never had fewer than a couple of hundred relations in the place.
15  *   Mr. Bilbo never did a kinder deed than when he brought the lad back
16  *   to live among decent folk.'                           --the Gaffer
17  *
18  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
19  */
20
21 /* XXX DAPM
22  * As of Sept 2002, this file is new and may be in a state of flux for
23  * a while. I've marked things I intent to come back and look at further
24  * with an 'XXX DAPM' comment.
25  */
26
27 /*
28 =head1 Pad Data Structures
29
30 =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              * If pad_reset is enabled, ‘current’ means different
749              * things depending on whether we are allocating a con-
750              * stant or a target.  For a target, things marked PADTMP
751              * can be reused; not so for constants.
752              */
753             if (++retval <= names_fill &&
754                    (sv = names[retval]) && sv != &PL_sv_undef)
755                 continue;
756             sv = *av_fetch(PL_comppad, retval, TRUE);
757             if (!(SvFLAGS(sv) &
758 #ifdef USE_PAD_RESET
759                     (SVs_PADMY|(konst ? SVs_PADTMP : 0))
760 #else
761                     (SVs_PADMY|SVs_PADTMP)
762 #endif
763                  ) &&
764                 !IS_PADGV(sv))
765                 break;
766         }
767         if (konst) {
768             av_store(PL_comppad_name, retval, &PL_sv_no);
769             tmptype &= ~SVf_READONLY;
770             tmptype |= SVs_PADTMP;
771         }
772         *(konst ? &PL_constpadix : &PL_padix) = retval;
773     }
774     SvFLAGS(sv) |= tmptype;
775     PL_curpad = AvARRAY(PL_comppad);
776
777     DEBUG_X(PerlIO_printf(Perl_debug_log,
778           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
779           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
780           PL_op_name[optype]));
781 #ifdef DEBUG_LEAKING_SCALARS
782     sv->sv_debug_optype = optype;
783     sv->sv_debug_inpad = 1;
784 #endif
785     return (PADOFFSET)retval;
786 }
787
788 /*
789 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
790
791 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
792 for an anonymous function that is lexically scoped inside the
793 currently-compiling function.
794 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
795 to the outer scope is weakened to avoid a reference loop.
796
797 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
798
799 I<optype> should be an opcode indicating the type of operation that the
800 pad entry is to support.  This doesn't affect operational semantics,
801 but is used for debugging.
802
803 =cut
804 */
805
806 PADOFFSET
807 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
808 {
809     PADOFFSET ix;
810     SV* const name = newSV_type(SVt_PVNV);
811
812     PERL_ARGS_ASSERT_PAD_ADD_ANON;
813
814     pad_peg("add_anon");
815     sv_setpvs(name, "&");
816     /* These two aren't used; just make sure they're not equal to
817      * PERL_PADSEQ_INTRO */
818     COP_SEQ_RANGE_LOW_set(name, 0);
819     COP_SEQ_RANGE_HIGH_set(name, 0);
820     ix = pad_alloc(optype, SVs_PADMY);
821     av_store(PL_comppad_name, ix, name);
822     /* XXX DAPM use PL_curpad[] ? */
823     if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
824         av_store(PL_comppad, ix, (SV*)func);
825     else {
826         SV *rv = newRV_noinc((SV *)func);
827         sv_rvweaken(rv);
828         assert (SvTYPE(func) == SVt_PVFM);
829         av_store(PL_comppad, ix, rv);
830     }
831     SvPADMY_on((SV*)func);
832
833     /* to avoid ref loops, we never have parent + child referencing each
834      * other simultaneously */
835     if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
836         assert(!CvWEAKOUTSIDE(func));
837         CvWEAKOUTSIDE_on(func);
838         SvREFCNT_dec_NN(CvOUTSIDE(func));
839     }
840     return ix;
841 }
842
843 /*
844 =for apidoc pad_check_dup
845
846 Check for duplicate declarations: report any of:
847
848      * a my in the current scope with the same name;
849      * an our (anywhere in the pad) with the same name and the
850        same stash as C<ourstash>
851
852 C<is_our> indicates that the name to check is an 'our' declaration.
853
854 =cut
855 */
856
857 STATIC void
858 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
859 {
860     SV          **svp;
861     PADOFFSET   top, off;
862     const U32   is_our = flags & padadd_OUR;
863
864     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
865
866     ASSERT_CURPAD_ACTIVE("pad_check_dup");
867
868     assert((flags & ~padadd_OUR) == 0);
869
870     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
871         return; /* nothing to check */
872
873     svp = AvARRAY(PL_comppad_name);
874     top = AvFILLp(PL_comppad_name);
875     /* check the current scope */
876     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
877      * type ? */
878     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
879         SV * const sv = svp[off];
880         if (sv
881             && PadnameLEN(sv)
882             && !SvFAKE(sv)
883             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
884                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
885             && sv_eq(name, sv))
886         {
887             if (is_our && (SvPAD_OUR(sv)))
888                 break; /* "our" masking "our" */
889             /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
890             Perl_warner(aTHX_ packWARN(WARN_MISC),
891                 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
892                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
893                 *SvPVX(sv) == '&' ? "subroutine" : "variable",
894                 SVfARG(sv),
895                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
896                     ? "scope" : "statement"));
897             --off;
898             break;
899         }
900     }
901     /* check the rest of the pad */
902     if (is_our) {
903         while (off > 0) {
904             SV * const sv = svp[off];
905             if (sv
906                 && PadnameLEN(sv)
907                 && !SvFAKE(sv)
908                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
909                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
910                 && SvOURSTASH(sv) == ourstash
911                 && sv_eq(name, sv))
912             {
913                 Perl_warner(aTHX_ packWARN(WARN_MISC),
914                     "\"our\" variable %"SVf" redeclared", SVfARG(sv));
915                 if ((I32)off <= PL_comppad_name_floor)
916                     Perl_warner(aTHX_ packWARN(WARN_MISC),
917                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
918                 break;
919             }
920             --off;
921         }
922     }
923 }
924
925
926 /*
927 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
928
929 Given the name of a lexical variable, find its position in the
930 currently-compiling pad.
931 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
932 I<flags> is reserved and must be zero.
933 If it is not in the current pad but appears in the pad of any lexically
934 enclosing scope, then a pseudo-entry for it is added in the current pad.
935 Returns the offset in the current pad,
936 or C<NOT_IN_PAD> if no such lexical is in scope.
937
938 =cut
939 */
940
941 PADOFFSET
942 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
943 {
944     SV *out_sv;
945     int out_flags;
946     I32 offset;
947     const AV *nameav;
948     SV **name_svp;
949
950     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
951
952     pad_peg("pad_findmy_pvn");
953
954     if (flags & ~padadd_UTF8_NAME)
955         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
956                    (UV)flags);
957
958     if (flags & padadd_UTF8_NAME) {
959         bool is_utf8 = TRUE;
960         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
961
962         if (is_utf8)
963             flags |= padadd_UTF8_NAME;
964         else
965             flags &= ~padadd_UTF8_NAME;
966     }
967
968     offset = pad_findlex(namepv, namelen, flags,
969                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
970     if ((PADOFFSET)offset != NOT_IN_PAD) 
971         return offset;
972
973     /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
974      */
975     if (*namepv == '&') return NOT_IN_PAD;
976
977     /* look for an our that's being introduced; this allows
978      *    our $foo = 0 unless defined $foo;
979      * to not give a warning. (Yes, this is a hack) */
980
981     nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
982     name_svp = AvARRAY(nameav);
983     for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
984         const SV * const namesv = name_svp[offset];
985         if (namesv && PadnameLEN(namesv) == namelen
986             && !SvFAKE(namesv)
987             && (SvPAD_OUR(namesv))
988             && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
989                                 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
990             && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
991         )
992             return offset;
993     }
994     return NOT_IN_PAD;
995 }
996
997 /*
998 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
999
1000 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1001 instead of a string/length pair.
1002
1003 =cut
1004 */
1005
1006 PADOFFSET
1007 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1008 {
1009     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1010     return pad_findmy_pvn(name, strlen(name), flags);
1011 }
1012
1013 /*
1014 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1015
1016 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1017 of an SV instead of a string/length pair.
1018
1019 =cut
1020 */
1021
1022 PADOFFSET
1023 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1024 {
1025     char *namepv;
1026     STRLEN namelen;
1027     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1028     namepv = SvPV(name, namelen);
1029     if (SvUTF8(name))
1030         flags |= padadd_UTF8_NAME;
1031     return pad_findmy_pvn(namepv, namelen, flags);
1032 }
1033
1034 /*
1035 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1036
1037 Find the position of the lexical C<$_> in the pad of the
1038 currently-executing function.  Returns the offset in the current pad,
1039 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1040 the global one should be used instead).
1041 L</find_rundefsv> is likely to be more convenient.
1042
1043 =cut
1044 */
1045
1046 PADOFFSET
1047 Perl_find_rundefsvoffset(pTHX)
1048 {
1049     SV *out_sv;
1050     int out_flags;
1051     return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1052             NULL, &out_sv, &out_flags);
1053 }
1054
1055 /*
1056 =for apidoc Am|SV *|find_rundefsv
1057
1058 Find and return the variable that is named C<$_> in the lexical scope
1059 of the currently-executing function.  This may be a lexical C<$_>,
1060 or will otherwise be the global one.
1061
1062 =cut
1063 */
1064
1065 SV *
1066 Perl_find_rundefsv(pTHX)
1067 {
1068     SV *namesv;
1069     int flags;
1070     PADOFFSET po;
1071
1072     po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1073             NULL, &namesv, &flags);
1074
1075     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1076         return DEFSV;
1077
1078     return PAD_SVl(po);
1079 }
1080
1081 SV *
1082 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1083 {
1084     SV *namesv;
1085     int flags;
1086     PADOFFSET po;
1087
1088     PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1089
1090     po = pad_findlex("$_", 2, 0, cv, seq, 1,
1091             NULL, &namesv, &flags);
1092
1093     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1094         return DEFSV;
1095
1096     return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1097 }
1098
1099 /*
1100 =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
1101
1102 Find a named lexical anywhere in a chain of nested pads.  Add fake entries
1103 in the inner pads if it's found in an outer one.
1104
1105 Returns the offset in the bottom pad of the lex or the fake lex.
1106 cv is the CV in which to start the search, and seq is the current cop_seq
1107 to match against.  If warn is true, print appropriate warnings.  The out_*
1108 vars return values, and so are pointers to where the returned values
1109 should be stored.  out_capture, if non-null, requests that the innermost
1110 instance of the lexical is captured; out_name_sv is set to the innermost
1111 matched namesv or fake namesv; out_flags returns the flags normally
1112 associated with the IVX field of a fake namesv.
1113
1114 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1115 then comes back down, adding fake entries
1116 as it goes.  It has to be this way
1117 because fake namesvs in anon protoypes have to store in xlow the index into
1118 the parent pad.
1119
1120 =cut
1121 */
1122
1123 /* the CV has finished being compiled. This is not a sufficient test for
1124  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1125 #define CvCOMPILED(cv)  CvROOT(cv)
1126
1127 /* the CV does late binding of its lexicals */
1128 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1129
1130 static void
1131 S_unavailable(pTHX_ SV *namesv)
1132 {
1133     /* diag_listed_as: Variable "%s" is not available */
1134     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1135                         "%se \"%"SVf"\" is not available",
1136                          *SvPVX_const(namesv) == '&'
1137                                          ? "Subroutin"
1138                                          : "Variabl",
1139                          SVfARG(namesv));
1140 }
1141
1142 STATIC PADOFFSET
1143 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1144         int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1145 {
1146     I32 offset, new_offset;
1147     SV *new_capture;
1148     SV **new_capturep;
1149     const PADLIST * const padlist = CvPADLIST(cv);
1150     const bool staleok = !!(flags & padadd_STALEOK);
1151
1152     PERL_ARGS_ASSERT_PAD_FINDLEX;
1153
1154     if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1155         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1156                    (UV)flags);
1157     flags &= ~ padadd_STALEOK; /* one-shot flag */
1158
1159     *out_flags = 0;
1160
1161     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1162         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1163                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1164         out_capture ? " capturing" : "" ));
1165
1166     /* first, search this pad */
1167
1168     if (padlist) { /* not an undef CV */
1169         I32 fake_offset = 0;
1170         const AV * const nameav = PadlistARRAY(padlist)[0];
1171         SV * const * const name_svp = AvARRAY(nameav);
1172
1173         for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1174             const SV * const namesv = name_svp[offset];
1175             if (namesv && PadnameLEN(namesv) == namelen
1176                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1177                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1178             {
1179                 if (SvFAKE(namesv)) {
1180                     fake_offset = offset; /* in case we don't find a real one */
1181                     continue;
1182                 }
1183                 /* is seq within the range _LOW to _HIGH ?
1184                  * This is complicated by the fact that PL_cop_seqmax
1185                  * may have wrapped around at some point */
1186                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1187                     continue; /* not yet introduced */
1188
1189                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1190                     /* in compiling scope */
1191                     if (
1192                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1193                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1194                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1195                     )
1196                        break;
1197                 }
1198                 else if (
1199                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1200                     ?
1201                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1202                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1203
1204                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1205                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1206                 )
1207                 break;
1208             }
1209         }
1210
1211         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1212             if (offset > 0) { /* not fake */
1213                 fake_offset = 0;
1214                 *out_name_sv = name_svp[offset]; /* return the namesv */
1215
1216                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1217                  * instances. For now, we just test !CvUNIQUE(cv), but
1218                  * ideally, we should detect my's declared within loops
1219                  * etc - this would allow a wider range of 'not stayed
1220                  * shared' warnings. We also treated already-compiled
1221                  * lexes as not multi as viewed from evals. */
1222
1223                 *out_flags = CvANON(cv) ?
1224                         PAD_FAKELEX_ANON :
1225                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1226                                 ? PAD_FAKELEX_MULTI : 0;
1227
1228                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1229                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1230                     PTR2UV(cv), (long)offset,
1231                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1232                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1233             }
1234             else { /* fake match */
1235                 offset = fake_offset;
1236                 *out_name_sv = name_svp[offset]; /* return the namesv */
1237                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1238                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1239                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1240                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1241                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1242                 ));
1243             }
1244
1245             /* return the lex? */
1246
1247             if (out_capture) {
1248
1249                 /* our ? */
1250                 if (SvPAD_OUR(*out_name_sv)) {
1251                     *out_capture = NULL;
1252                     return offset;
1253                 }
1254
1255                 /* trying to capture from an anon prototype? */
1256                 if (CvCOMPILED(cv)
1257                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1258                         : *out_flags & PAD_FAKELEX_ANON)
1259                 {
1260                     if (warn)
1261                         S_unavailable(aTHX_
1262                                        newSVpvn_flags(namepv, namelen,
1263                                            SVs_TEMP |
1264                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1265
1266                     *out_capture = NULL;
1267                 }
1268
1269                 /* real value */
1270                 else {
1271                     int newwarn = warn;
1272                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1273                          && !SvPAD_STATE(name_svp[offset])
1274                          && warn && ckWARN(WARN_CLOSURE)) {
1275                         newwarn = 0;
1276                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1277                             "Variable \"%"SVf"\" will not stay shared",
1278                             SVfARG(newSVpvn_flags(namepv, namelen,
1279                                 SVs_TEMP |
1280                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1281                     }
1282
1283                     if (fake_offset && CvANON(cv)
1284                             && CvCLONE(cv) &&!CvCLONED(cv))
1285                     {
1286                         SV *n;
1287                         /* not yet caught - look further up */
1288                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1289                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1290                             PTR2UV(cv)));
1291                         n = *out_name_sv;
1292                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1293                             CvOUTSIDE_SEQ(cv),
1294                             newwarn, out_capture, out_name_sv, out_flags);
1295                         *out_name_sv = n;
1296                         return offset;
1297                     }
1298
1299                     *out_capture = AvARRAY(PadlistARRAY(padlist)[
1300                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1301                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1302                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1303                         PTR2UV(cv), PTR2UV(*out_capture)));
1304
1305                     if (SvPADSTALE(*out_capture)
1306                         && (!CvDEPTH(cv) || !staleok)
1307                         && !SvPAD_STATE(name_svp[offset]))
1308                     {
1309                         S_unavailable(aTHX_
1310                                        newSVpvn_flags(namepv, namelen,
1311                                            SVs_TEMP |
1312                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1313                         *out_capture = NULL;
1314                     }
1315                 }
1316                 if (!*out_capture) {
1317                     if (namelen != 0 && *namepv == '@')
1318                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1319                     else if (namelen != 0 && *namepv == '%')
1320                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1321                     else if (namelen != 0 && *namepv == '&')
1322                         *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1323                     else
1324                         *out_capture = sv_newmortal();
1325                 }
1326             }
1327
1328             return offset;
1329         }
1330     }
1331
1332     /* it's not in this pad - try above */
1333
1334     if (!CvOUTSIDE(cv))
1335         return NOT_IN_PAD;
1336
1337     /* out_capture non-null means caller wants us to capture lex; in
1338      * addition we capture ourselves unless it's an ANON/format */
1339     new_capturep = out_capture ? out_capture :
1340                 CvLATE(cv) ? NULL : &new_capture;
1341
1342     offset = pad_findlex(namepv, namelen,
1343                 flags | padadd_STALEOK*(new_capturep == &new_capture),
1344                 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1345                 new_capturep, out_name_sv, out_flags);
1346     if ((PADOFFSET)offset == NOT_IN_PAD)
1347         return NOT_IN_PAD;
1348
1349     /* found in an outer CV. Add appropriate fake entry to this pad */
1350
1351     /* don't add new fake entries (via eval) to CVs that we have already
1352      * finished compiling, or to undef CVs */
1353     if (CvCOMPILED(cv) || !padlist)
1354         return 0; /* this dummy (and invalid) value isnt used by the caller */
1355
1356     {
1357         /* This relies on sv_setsv_flags() upgrading the destination to the same
1358            type as the source, independent of the flags set, and on it being
1359            "good" and only copying flag bits and pointers that it understands.
1360         */
1361         SV *new_namesv = newSVsv(*out_name_sv);
1362         AV *  const ocomppad_name = PL_comppad_name;
1363         PAD * const ocomppad = PL_comppad;
1364         PL_comppad_name = PadlistARRAY(padlist)[0];
1365         PL_comppad = PadlistARRAY(padlist)[1];
1366         PL_curpad = AvARRAY(PL_comppad);
1367
1368         new_offset
1369             = pad_alloc_name(new_namesv,
1370                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1371                               SvPAD_TYPED(*out_name_sv)
1372                               ? SvSTASH(*out_name_sv) : NULL,
1373                               SvOURSTASH(*out_name_sv)
1374                               );
1375
1376         SvFAKE_on(new_namesv);
1377         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1378                                "Pad addname: %ld \"%.*s\" FAKE\n",
1379                                (long)new_offset,
1380                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1381         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1382
1383         PARENT_PAD_INDEX_set(new_namesv, 0);
1384         if (SvPAD_OUR(new_namesv)) {
1385             NOOP;   /* do nothing */
1386         }
1387         else if (CvLATE(cv)) {
1388             /* delayed creation - just note the offset within parent pad */
1389             PARENT_PAD_INDEX_set(new_namesv, offset);
1390             CvCLONE_on(cv);
1391         }
1392         else {
1393             /* immediate creation - capture outer value right now */
1394             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1395             /* But also note the offset, as newMYSUB needs it */
1396             PARENT_PAD_INDEX_set(new_namesv, offset);
1397             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1398                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1399                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1400         }
1401         *out_name_sv = new_namesv;
1402         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1403
1404         PL_comppad_name = ocomppad_name;
1405         PL_comppad = ocomppad;
1406         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1407     }
1408     return new_offset;
1409 }
1410
1411 #ifdef DEBUGGING
1412
1413 /*
1414 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1415
1416 Get the value at offset I<po> in the current (compiling or executing) pad.
1417 Use macro PAD_SV instead of calling this function directly.
1418
1419 =cut
1420 */
1421
1422 SV *
1423 Perl_pad_sv(pTHX_ PADOFFSET po)
1424 {
1425     ASSERT_CURPAD_ACTIVE("pad_sv");
1426
1427     if (!po)
1428         Perl_croak(aTHX_ "panic: pad_sv po");
1429     DEBUG_X(PerlIO_printf(Perl_debug_log,
1430         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1431         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1432     );
1433     return PL_curpad[po];
1434 }
1435
1436 /*
1437 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1438
1439 Set the value at offset I<po> in the current (compiling or executing) pad.
1440 Use the macro PAD_SETSV() rather than calling this function directly.
1441
1442 =cut
1443 */
1444
1445 void
1446 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1447 {
1448     PERL_ARGS_ASSERT_PAD_SETSV;
1449
1450     ASSERT_CURPAD_ACTIVE("pad_setsv");
1451
1452     DEBUG_X(PerlIO_printf(Perl_debug_log,
1453         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1454         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1455     );
1456     PL_curpad[po] = sv;
1457 }
1458
1459 #endif /* DEBUGGING */
1460
1461 /*
1462 =for apidoc m|void|pad_block_start|int full
1463
1464 Update the pad compilation state variables on entry to a new block.
1465
1466 =cut
1467 */
1468
1469 /* XXX DAPM perhaps:
1470  *      - integrate this in general state-saving routine ???
1471  *      - combine with the state-saving going on in pad_new ???
1472  *      - introduce a new SAVE type that does all this in one go ?
1473  */
1474
1475 void
1476 Perl_pad_block_start(pTHX_ int full)
1477 {
1478     ASSERT_CURPAD_ACTIVE("pad_block_start");
1479     SAVEI32(PL_comppad_name_floor);
1480     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1481     if (full)
1482         PL_comppad_name_fill = PL_comppad_name_floor;
1483     if (PL_comppad_name_floor < 0)
1484         PL_comppad_name_floor = 0;
1485     SAVEI32(PL_min_intro_pending);
1486     SAVEI32(PL_max_intro_pending);
1487     PL_min_intro_pending = 0;
1488     SAVEI32(PL_comppad_name_fill);
1489     SAVEI32(PL_padix_floor);
1490     /* PL_padix_floor is what PL_padix is reset to at the start of each
1491        statement, by pad_reset().  We set it when entering a new scope
1492        to keep things like this working:
1493             print "$foo$bar", do { this(); that() . "foo" };
1494        We must not let "$foo$bar" and the later concatenation share the
1495        same target.  */
1496     PL_padix_floor = PL_padix;
1497     PL_pad_reset_pending = FALSE;
1498 }
1499
1500 /*
1501 =for apidoc m|U32|intro_my
1502
1503 "Introduce" my variables to visible status.  This is called during parsing
1504 at the end of each statement to make lexical variables visible to
1505 subsequent statements.
1506
1507 =cut
1508 */
1509
1510 U32
1511 Perl_intro_my(pTHX)
1512 {
1513     SV **svp;
1514     I32 i;
1515     U32 seq;
1516
1517     ASSERT_CURPAD_ACTIVE("intro_my");
1518     if (! PL_min_intro_pending)
1519         return PL_cop_seqmax;
1520
1521     svp = AvARRAY(PL_comppad_name);
1522     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1523         SV * const sv = svp[i];
1524
1525         if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1526             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1527         {
1528             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1529             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1530             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1531                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1532                 (long)i, SvPVX_const(sv),
1533                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1534                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1535             );
1536         }
1537     }
1538     seq = PL_cop_seqmax;
1539     PL_cop_seqmax++;
1540     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1541         PL_cop_seqmax++;
1542     PL_min_intro_pending = 0;
1543     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1544     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1545                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1546
1547     return seq;
1548 }
1549
1550 /*
1551 =for apidoc m|void|pad_leavemy
1552
1553 Cleanup at end of scope during compilation: set the max seq number for
1554 lexicals in this scope and warn of any lexicals that never got introduced.
1555
1556 =cut
1557 */
1558
1559 OP *
1560 Perl_pad_leavemy(pTHX)
1561 {
1562     I32 off;
1563     OP *o = NULL;
1564     SV * const * const svp = AvARRAY(PL_comppad_name);
1565
1566     PL_pad_reset_pending = FALSE;
1567
1568     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1569     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1570         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1571             const SV * const sv = svp[off];
1572             if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1573                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1574                                  "%"SVf" never introduced",
1575                                  SVfARG(sv));
1576         }
1577     }
1578     /* "Deintroduce" my variables that are leaving with this scope. */
1579     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1580         SV * const sv = svp[off];
1581         if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1582             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1583         {
1584             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1585             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1586                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1587                 (long)off, SvPVX_const(sv),
1588                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1589                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1590             );
1591             if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1592              && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1593                 OP *kid = newOP(OP_INTROCV, 0);
1594                 kid->op_targ = off;
1595                 o = op_prepend_elem(OP_LINESEQ, kid, o);
1596             }
1597         }
1598     }
1599     PL_cop_seqmax++;
1600     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1601         PL_cop_seqmax++;
1602     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1603             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1604     return o;
1605 }
1606
1607 /*
1608 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1609
1610 Abandon the tmp in the current pad at offset po and replace with a
1611 new one.
1612
1613 =cut
1614 */
1615
1616 void
1617 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1618 {
1619     ASSERT_CURPAD_LEGAL("pad_swipe");
1620     if (!PL_curpad)
1621         return;
1622     if (AvARRAY(PL_comppad) != PL_curpad)
1623         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1624                    AvARRAY(PL_comppad), PL_curpad);
1625     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1626         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1627                    (long)po, (long)AvFILLp(PL_comppad));
1628
1629     DEBUG_X(PerlIO_printf(Perl_debug_log,
1630                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1631                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1632
1633     if (refadjust)
1634         SvREFCNT_dec(PL_curpad[po]);
1635
1636
1637     /* if pad tmps aren't shared between ops, then there's no need to
1638      * create a new tmp when an existing op is freed */
1639 #ifdef USE_PAD_RESET
1640     PL_curpad[po] = newSV(0);
1641     SvPADTMP_on(PL_curpad[po]);
1642 #else
1643     PL_curpad[po] = NULL;
1644 #endif
1645     if (PadnamelistMAX(PL_comppad_name) != -1
1646      && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1647         if (PadnamelistARRAY(PL_comppad_name)[po]) {
1648             assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1649         }
1650         PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1651     }
1652     /* Use PL_constpadix here, not PL_padix.  The latter may have been
1653        reset by pad_reset.  We don’t want pad_alloc to have to scan the
1654        whole pad when allocating a constant. */
1655     if ((I32)po < PL_constpadix)
1656         PL_constpadix = po - 1;
1657 }
1658
1659 /*
1660 =for apidoc m|void|pad_reset
1661
1662 Mark all the current temporaries for reuse
1663
1664 =cut
1665 */
1666
1667 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1668  * between OPs from different statements.  During compilation, at the start
1669  * of each statement pad_reset resets PL_padix back to its previous value.
1670  * When allocating a target, pad_alloc begins its scan through the pad at
1671  * PL_padix+1.  */
1672 static void
1673 S_pad_reset(pTHX)
1674 {
1675 #ifdef USE_PAD_RESET
1676     if (AvARRAY(PL_comppad) != PL_curpad)
1677         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1678                    AvARRAY(PL_comppad), PL_curpad);
1679
1680     DEBUG_X(PerlIO_printf(Perl_debug_log,
1681             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1682             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1683                 (long)PL_padix, (long)PL_padix_floor
1684             )
1685     );
1686
1687     if (!TAINTING_get) {        /* Can't mix tainted and non-tainted temporaries. */
1688         PL_padix = PL_padix_floor;
1689     }
1690 #endif
1691     PL_pad_reset_pending = FALSE;
1692 }
1693
1694 /*
1695 =for apidoc Amx|void|pad_tidy|padtidy_type type
1696
1697 Tidy up a pad at the end of compilation of the code to which it belongs.
1698 Jobs performed here are: remove most stuff from the pads of anonsub
1699 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1700 the kind of subroutine:
1701
1702     padtidy_SUB        ordinary subroutine
1703     padtidy_SUBCLONE   prototype for lexical closure
1704     padtidy_FORMAT     format
1705
1706 =cut
1707 */
1708
1709 /* XXX DAPM surely most of this stuff should be done properly
1710  * at the right time beforehand, rather than going around afterwards
1711  * cleaning up our mistakes ???
1712  */
1713
1714 void
1715 Perl_pad_tidy(pTHX_ padtidy_type type)
1716 {
1717     dVAR;
1718
1719     ASSERT_CURPAD_ACTIVE("pad_tidy");
1720
1721     /* If this CV has had any 'eval-capable' ops planted in it:
1722      * i.e. it contains any of:
1723      *
1724      *     * eval '...',
1725      *     * //ee,
1726      *     * use re 'eval'; /$var/
1727      *     * /(?{..})/),
1728      *
1729      * Then any anon prototypes in the chain of CVs should be marked as
1730      * cloneable, so that for example the eval's CV in
1731      *
1732      *    sub { eval '$x' }
1733      *
1734      * gets the right CvOUTSIDE.  If running with -d, *any* sub may
1735      * potentially have an eval executed within it.
1736      */
1737
1738     if (PL_cv_has_eval || PL_perldb) {
1739         const CV *cv;
1740         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1741             if (cv != PL_compcv && CvCOMPILED(cv))
1742                 break; /* no need to mark already-compiled code */
1743             if (CvANON(cv)) {
1744                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1745                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1746                 CvCLONE_on(cv);
1747             }
1748             CvHASEVAL_on(cv);
1749         }
1750     }
1751
1752     /* extend namepad to match curpad */
1753     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1754         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1755
1756     if (type == padtidy_SUBCLONE) {
1757         SV ** const namep = AvARRAY(PL_comppad_name);
1758         PADOFFSET ix;
1759
1760         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1761             SV *namesv;
1762             if (!namep[ix]) namep[ix] = &PL_sv_undef;
1763
1764             /*
1765              * The only things that a clonable function needs in its
1766              * pad are anonymous subs, constants and GVs.
1767              * The rest are created anew during cloning.
1768              */
1769             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1770                  || IS_PADGV(PL_curpad[ix]))
1771                 continue;
1772             namesv = namep[ix];
1773             if (!(PadnamePV(namesv) &&
1774                    (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1775             {
1776                 SvREFCNT_dec(PL_curpad[ix]);
1777                 PL_curpad[ix] = NULL;
1778             }
1779         }
1780     }
1781     else if (type == padtidy_SUB) {
1782         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1783         AV * const av = newAV();                        /* Will be @_ */
1784         av_store(PL_comppad, 0, MUTABLE_SV(av));
1785         AvREIFY_only(av);
1786     }
1787
1788     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1789         SV ** const namep = AvARRAY(PL_comppad_name);
1790         PADOFFSET ix;
1791         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1792             if (!namep[ix]) namep[ix] = &PL_sv_undef;
1793             if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1794                  || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1795                 continue;
1796             if (!SvPADMY(PL_curpad[ix])) {
1797                 SvPADTMP_on(PL_curpad[ix]);
1798             } else if (!SvFAKE(namep[ix])) {
1799                 /* This is a work around for how the current implementation of
1800                    ?{ } blocks in regexps interacts with lexicals.
1801
1802                    One of our lexicals.
1803                    Can't do this on all lexicals, otherwise sub baz() won't
1804                    compile in
1805
1806                    my $foo;
1807
1808                    sub bar { ++$foo; }
1809
1810                    sub baz { ++$foo; }
1811
1812                    because completion of compiling &bar calling pad_tidy()
1813                    would cause (top level) $foo to be marked as stale, and
1814                    "no longer available".  */
1815                 SvPADSTALE_on(PL_curpad[ix]);
1816             }
1817         }
1818     }
1819     PL_curpad = AvARRAY(PL_comppad);
1820 }
1821
1822 /*
1823 =for apidoc m|void|pad_free|PADOFFSET po
1824
1825 Free the SV at offset po in the current pad.
1826
1827 =cut
1828 */
1829
1830 /* XXX DAPM integrate with pad_swipe ???? */
1831 void
1832 Perl_pad_free(pTHX_ PADOFFSET po)
1833 {
1834 #ifndef USE_PAD_RESET
1835     SV *sv;
1836 #endif
1837     ASSERT_CURPAD_LEGAL("pad_free");
1838     if (!PL_curpad)
1839         return;
1840     if (AvARRAY(PL_comppad) != PL_curpad)
1841         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1842                    AvARRAY(PL_comppad), PL_curpad);
1843     if (!po)
1844         Perl_croak(aTHX_ "panic: pad_free po");
1845
1846     DEBUG_X(PerlIO_printf(Perl_debug_log,
1847             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1848             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1849     );
1850
1851 #ifndef USE_PAD_RESET
1852     sv = PL_curpad[po];
1853     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1854         SvFLAGS(sv) &= ~SVs_PADTMP;
1855
1856     if ((I32)po < PL_padix)
1857         PL_padix = po - 1;
1858 #endif
1859 }
1860
1861 /*
1862 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1863
1864 Dump the contents of a padlist
1865
1866 =cut
1867 */
1868
1869 void
1870 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1871 {
1872     const AV *pad_name;
1873     const AV *pad;
1874     SV **pname;
1875     SV **ppad;
1876     I32 ix;
1877
1878     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1879
1880     if (!padlist) {
1881         return;
1882     }
1883     pad_name = *PadlistARRAY(padlist);
1884     pad = PadlistARRAY(padlist)[1];
1885     pname = AvARRAY(pad_name);
1886     ppad = AvARRAY(pad);
1887     Perl_dump_indent(aTHX_ level, file,
1888             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1889             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1890     );
1891
1892     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1893         const SV *namesv = pname[ix];
1894         if (namesv && !PadnameLEN(namesv)) {
1895             namesv = NULL;
1896         }
1897         if (namesv) {
1898             if (SvFAKE(namesv))
1899                 Perl_dump_indent(aTHX_ level+1, file,
1900                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1901                     (int) ix,
1902                     PTR2UV(ppad[ix]),
1903                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1904                     SvPVX_const(namesv),
1905                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1906                     (unsigned long)PARENT_PAD_INDEX(namesv)
1907
1908                 );
1909             else
1910                 Perl_dump_indent(aTHX_ level+1, file,
1911                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1912                     (int) ix,
1913                     PTR2UV(ppad[ix]),
1914                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1915                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1916                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1917                     SvPVX_const(namesv)
1918                 );
1919         }
1920         else if (full) {
1921             Perl_dump_indent(aTHX_ level+1, file,
1922                 "%2d. 0x%"UVxf"<%lu>\n",
1923                 (int) ix,
1924                 PTR2UV(ppad[ix]),
1925                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1926             );
1927         }
1928     }
1929 }
1930
1931 #ifdef DEBUGGING
1932
1933 /*
1934 =for apidoc m|void|cv_dump|CV *cv|const char *title
1935
1936 dump the contents of a CV
1937
1938 =cut
1939 */
1940
1941 STATIC void
1942 S_cv_dump(pTHX_ const CV *cv, const char *title)
1943 {
1944     const CV * const outside = CvOUTSIDE(cv);
1945     PADLIST* const padlist = CvPADLIST(cv);
1946
1947     PERL_ARGS_ASSERT_CV_DUMP;
1948
1949     PerlIO_printf(Perl_debug_log,
1950                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1951                   title,
1952                   PTR2UV(cv),
1953                   (CvANON(cv) ? "ANON"
1954                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1955                    : (cv == PL_main_cv) ? "MAIN"
1956                    : CvUNIQUE(cv) ? "UNIQUE"
1957                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1958                   PTR2UV(outside),
1959                   (!outside ? "null"
1960                    : CvANON(outside) ? "ANON"
1961                    : (outside == PL_main_cv) ? "MAIN"
1962                    : CvUNIQUE(outside) ? "UNIQUE"
1963                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1964
1965     PerlIO_printf(Perl_debug_log,
1966                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1967     do_dump_pad(1, Perl_debug_log, padlist, 1);
1968 }
1969
1970 #endif /* DEBUGGING */
1971
1972 /*
1973 =for apidoc Am|CV *|cv_clone|CV *proto
1974
1975 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1976 of the function: its code, pad structure, and other attributes.
1977 The prototype is combined with a capture of outer lexicals to which the
1978 code refers, which are taken from the currently-executing instance of
1979 the immediately surrounding code.
1980
1981 =cut
1982 */
1983
1984 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1985
1986 static void
1987 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1988 {
1989     I32 ix;
1990     PADLIST* const protopadlist = CvPADLIST(proto);
1991     PAD *const protopad_name = *PadlistARRAY(protopadlist);
1992     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1993     SV** const pname = AvARRAY(protopad_name);
1994     SV** const ppad = AvARRAY(protopad);
1995     const I32 fname = AvFILLp(protopad_name);
1996     const I32 fpad = AvFILLp(protopad);
1997     SV** outpad;
1998     long depth;
1999     bool subclones = FALSE;
2000
2001     assert(!CvUNIQUE(proto));
2002
2003     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2004      * reliable.  The currently-running sub is always the one we need to
2005      * close over.
2006      * For my subs, the currently-running sub may not be the one we want.
2007      * We have to check whether it is a clone of CvOUTSIDE.
2008      * Note that in general for formats, CvOUTSIDE != find_runcv.
2009      * Since formats may be nested inside closures, CvOUTSIDE may point
2010      * to a prototype; we instead want the cloned parent who called us.
2011      */
2012
2013     if (!outside) {
2014       if (CvWEAKOUTSIDE(proto))
2015         outside = find_runcv(NULL);
2016       else {
2017         outside = CvOUTSIDE(proto);
2018         if ((CvCLONE(outside) && ! CvCLONED(outside))
2019             || !CvPADLIST(outside)
2020             || PadlistNAMES(CvPADLIST(outside))
2021                  != protopadlist->xpadl_outid) {
2022             outside = find_runcv_where(
2023                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2024             );
2025             /* outside could be null */
2026         }
2027       }
2028     }
2029     depth = outside ? CvDEPTH(outside) : 0;
2030     if (!depth)
2031         depth = 1;
2032
2033     ENTER;
2034     SAVESPTR(PL_compcv);
2035     PL_compcv = cv;
2036     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2037
2038     if (CvHASEVAL(cv))
2039         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2040
2041     SAVESPTR(PL_comppad_name);
2042     PL_comppad_name = protopad_name;
2043     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2044
2045     av_fill(PL_comppad, fpad);
2046
2047     PL_curpad = AvARRAY(PL_comppad);
2048
2049     outpad = outside && CvPADLIST(outside)
2050         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2051         : NULL;
2052     if (outpad)
2053         CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2054
2055     for (ix = fpad; ix > 0; ix--) {
2056         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2057         SV *sv = NULL;
2058         if (namesv && PadnameLEN(namesv)) { /* lexical */
2059           if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2060                 NOOP;
2061           }
2062           else {
2063             if (SvFAKE(namesv)) {   /* lexical from outside? */
2064                 /* formats may have an inactive, or even undefined, parent;
2065                    but state vars are always available. */
2066                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2067                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2068                     && (!outside || !CvDEPTH(outside)))  ) {
2069                     S_unavailable(aTHX_ namesv);
2070                     sv = NULL;
2071                 }
2072                 else 
2073                     SvREFCNT_inc_simple_void_NN(sv);
2074             }
2075             if (!sv) {
2076                 const char sigil = SvPVX_const(namesv)[0];
2077                 if (sigil == '&')
2078                     /* If there are state subs, we need to clone them, too.
2079                        But they may need to close over variables we have
2080                        not cloned yet.  So we will have to do a second
2081                        pass.  Furthermore, there may be state subs clos-
2082                        ing over other state subs’ entries, so we have
2083                        to put a stub here and then clone into it on the
2084                        second pass. */
2085                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2086                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2087                         subclones = 1;
2088                         sv = newSV_type(SVt_PVCV);
2089                     }
2090                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2091                     {
2092                         /* my sub */
2093                         /* Just provide a stub, but name it.  It will be
2094                            upgrade to the real thing on scope entry. */
2095                         dVAR;
2096                         U32 hash;
2097                         PERL_HASH(hash, SvPVX_const(namesv)+1,
2098                                   SvCUR(namesv) - 1);
2099                         sv = newSV_type(SVt_PVCV);
2100                         CvNAME_HEK_set(
2101                             sv,
2102                             share_hek(SvPVX_const(namesv)+1,
2103                                       SvCUR(namesv) - 1
2104                                          * (SvUTF8(namesv) ? -1 : 1),
2105                                       hash)
2106                         );
2107                     }
2108                     else sv = SvREFCNT_inc(ppad[ix]);
2109                 else if (sigil == '@')
2110                     sv = MUTABLE_SV(newAV());
2111                 else if (sigil == '%')
2112                     sv = MUTABLE_SV(newHV());
2113                 else
2114                     sv = newSV(0);
2115                 SvPADMY_on(sv);
2116                 /* reset the 'assign only once' flag on each state var */
2117                 if (sigil != '&' && SvPAD_STATE(namesv))
2118                     SvPADSTALE_on(sv);
2119             }
2120           }
2121         }
2122         else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2123             sv = SvREFCNT_inc_NN(ppad[ix]);
2124         }
2125         else {
2126             sv = newSV(0);
2127             SvPADTMP_on(sv);
2128         }
2129         PL_curpad[ix] = sv;
2130     }
2131
2132     if (subclones)
2133         for (ix = fpad; ix > 0; ix--) {
2134             SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2135             if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2136              && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2137                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2138         }
2139
2140     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2141     LEAVE;
2142 }
2143
2144 static CV *
2145 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2146 {
2147 #ifdef USE_ITHREADS
2148     dVAR;
2149 #endif
2150     const bool newcv = !cv;
2151
2152     assert(!CvUNIQUE(proto));
2153
2154     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2155     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2156                                     |CVf_SLABBED);
2157     CvCLONED_on(cv);
2158
2159     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2160                                            : CvFILE(proto);
2161     if (CvNAMED(proto))
2162          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2163     else CvGV_set(cv,CvGV(proto));
2164     CvSTASH_set(cv, CvSTASH(proto));
2165     OP_REFCNT_LOCK;
2166     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2167     OP_REFCNT_UNLOCK;
2168     CvSTART(cv)         = CvSTART(proto);
2169     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2170
2171     if (SvPOK(proto)) {
2172         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2173         if (SvUTF8(proto))
2174            SvUTF8_on(MUTABLE_SV(cv));
2175     }
2176     if (SvMAGIC(proto))
2177         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2178
2179     if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2180
2181     DEBUG_Xv(
2182         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2183         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2184         cv_dump(proto,   "Proto");
2185         cv_dump(cv,      "To");
2186     );
2187
2188     if (CvCONST(cv)) {
2189         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2190          * The prototype was marked as a candiate for const-ization,
2191          * so try to grab the current const value, and if successful,
2192          * turn into a const sub:
2193          */
2194         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2195         if (const_sv) {
2196             SvREFCNT_dec_NN(cv);
2197             /* For this calling case, op_const_sv returns a *copy*, which we
2198                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2199                Need to fix how lib/constant.pm works to eliminate this.  */
2200             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2201         }
2202         else {
2203             CvCONST_off(cv);
2204         }
2205     }
2206
2207     return cv;
2208 }
2209
2210 CV *
2211 Perl_cv_clone(pTHX_ CV *proto)
2212 {
2213     PERL_ARGS_ASSERT_CV_CLONE;
2214
2215     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2216     return S_cv_clone(aTHX_ proto, NULL, NULL);
2217 }
2218
2219 /* Called only by pp_clonecv */
2220 CV *
2221 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2222 {
2223     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2224     cv_undef(target);
2225     return S_cv_clone(aTHX_ proto, target, NULL);
2226 }
2227
2228 /*
2229 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2230
2231 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2232 old_cv to new_cv if necessary.  Needed when a newly-compiled CV has to be
2233 moved to a pre-existing CV struct.
2234
2235 =cut
2236 */
2237
2238 void
2239 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2240 {
2241     I32 ix;
2242     AV * const comppad_name = PadlistARRAY(padlist)[0];
2243     AV * const comppad = PadlistARRAY(padlist)[1];
2244     SV ** const namepad = AvARRAY(comppad_name);
2245     SV ** const curpad = AvARRAY(comppad);
2246
2247     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2248     PERL_UNUSED_ARG(old_cv);
2249
2250     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2251         const SV * const namesv = namepad[ix];
2252         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2253             && *SvPVX_const(namesv) == '&')
2254         {
2255           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2256             MAGIC * const mg =
2257                 SvMAGICAL(curpad[ix])
2258                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2259                     : NULL;
2260             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2261             if (CvOUTSIDE(innercv) == old_cv) {
2262                 if (!CvWEAKOUTSIDE(innercv)) {
2263                     SvREFCNT_dec(old_cv);
2264                     SvREFCNT_inc_simple_void_NN(new_cv);
2265                 }
2266                 CvOUTSIDE(innercv) = new_cv;
2267             }
2268           }
2269           else { /* format reference */
2270             SV * const rv = curpad[ix];
2271             CV *innercv;
2272             if (!SvOK(rv)) continue;
2273             assert(SvROK(rv));
2274             assert(SvWEAKREF(rv));
2275             innercv = (CV *)SvRV(rv);
2276             assert(!CvWEAKOUTSIDE(innercv));
2277             SvREFCNT_dec(CvOUTSIDE(innercv));
2278             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2279           }
2280         }
2281     }
2282 }
2283
2284 /*
2285 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2286
2287 Push a new pad frame onto the padlist, unless there's already a pad at
2288 this depth, in which case don't bother creating a new one.  Then give
2289 the new pad an @_ in slot zero.
2290
2291 =cut
2292 */
2293
2294 void
2295 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2296 {
2297     PERL_ARGS_ASSERT_PAD_PUSH;
2298
2299     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2300         PAD** const svp = PadlistARRAY(padlist);
2301         AV* const newpad = newAV();
2302         SV** const oldpad = AvARRAY(svp[depth-1]);
2303         I32 ix = AvFILLp((const AV *)svp[1]);
2304         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2305         SV** const names = AvARRAY(svp[0]);
2306         AV *av;
2307
2308         for ( ;ix > 0; ix--) {
2309             if (names_fill >= ix && PadnameLEN(names[ix])) {
2310                 const char sigil = SvPVX_const(names[ix])[0];
2311                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2312                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2313                         || sigil == '&')
2314                 {
2315                     /* outer lexical or anon code */
2316                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2317                 }
2318                 else {          /* our own lexical */
2319                     SV *sv; 
2320                     if (sigil == '@')
2321                         sv = MUTABLE_SV(newAV());
2322                     else if (sigil == '%')
2323                         sv = MUTABLE_SV(newHV());
2324                     else
2325                         sv = newSV(0);
2326                     av_store(newpad, ix, sv);
2327                     SvPADMY_on(sv);
2328                 }
2329             }
2330             else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2331                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2332             }
2333             else {
2334                 /* save temporaries on recursion? */
2335                 SV * const sv = newSV(0);
2336                 av_store(newpad, ix, sv);
2337                 SvPADTMP_on(sv);
2338             }
2339         }
2340         av = newAV();
2341         av_store(newpad, 0, MUTABLE_SV(av));
2342         AvREIFY_only(av);
2343
2344         padlist_store(padlist, depth, newpad);
2345     }
2346 }
2347
2348 /*
2349 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2350
2351 Looks up the type of the lexical variable at position I<po> in the
2352 currently-compiling pad.  If the variable is typed, the stash of the
2353 class to which it is typed is returned.  If not, C<NULL> is returned.
2354
2355 =cut
2356 */
2357
2358 HV *
2359 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2360 {
2361     SV* const av = PAD_COMPNAME_SV(po);
2362     if ( SvPAD_TYPED(av) ) {
2363         return SvSTASH(av);
2364     }
2365     return NULL;
2366 }
2367
2368 #if defined(USE_ITHREADS)
2369
2370 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2371
2372 /*
2373 =for apidoc padlist_dup
2374
2375 Duplicates a pad.
2376
2377 =cut
2378 */
2379
2380 PADLIST *
2381 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2382 {
2383     PADLIST *dstpad;
2384     bool cloneall;
2385     PADOFFSET max;
2386
2387     PERL_ARGS_ASSERT_PADLIST_DUP;
2388
2389     if (!srcpad)
2390         return NULL;
2391
2392     cloneall = param->flags & CLONEf_COPY_STACKS
2393         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2394     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2395
2396     max = cloneall ? PadlistMAX(srcpad) : 1;
2397
2398     Newx(dstpad, 1, PADLIST);
2399     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2400     PadlistMAX(dstpad) = max;
2401     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2402
2403     if (cloneall) {
2404         PADOFFSET depth;
2405         for (depth = 0; depth <= max; ++depth)
2406             PadlistARRAY(dstpad)[depth] =
2407                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2408     } else {
2409         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2410            to build anything other than the first level of pads.  */
2411         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2412         AV *pad1;
2413         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2414         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2415         SV **oldpad = AvARRAY(srcpad1);
2416         SV **names;
2417         SV **pad1a;
2418         AV *args;
2419
2420         PadlistARRAY(dstpad)[0] =
2421             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2422         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2423
2424         pad1 = newAV();
2425
2426         av_extend(pad1, ix);
2427         PadlistARRAY(dstpad)[1] = pad1;
2428         pad1a = AvARRAY(pad1);
2429
2430         if (ix > -1) {
2431             AvFILLp(pad1) = ix;
2432
2433             for ( ;ix > 0; ix--) {
2434                 if (!oldpad[ix]) {
2435                     pad1a[ix] = NULL;
2436                 } else if (names_fill >= ix && names[ix] &&
2437                            PadnameLEN(names[ix])) {
2438                     const char sigil = SvPVX_const(names[ix])[0];
2439                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2440                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2441                         || sigil == '&')
2442                         {
2443                             /* outer lexical or anon code */
2444                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2445                         }
2446                     else {              /* our own lexical */
2447                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2448                             /* This is a work around for how the current
2449                                implementation of ?{ } blocks in regexps
2450                                interacts with lexicals.  */
2451                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2452                         } else {
2453                             SV *sv; 
2454                             
2455                             if (sigil == '@')
2456                                 sv = MUTABLE_SV(newAV());
2457                             else if (sigil == '%')
2458                                 sv = MUTABLE_SV(newHV());
2459                             else
2460                                 sv = newSV(0);
2461                             pad1a[ix] = sv;
2462                             SvPADMY_on(sv);
2463                         }
2464                     }
2465                 }
2466                 else if (IS_PADGV(oldpad[ix])
2467                       || (  names_fill >= ix && names[ix]
2468                          && PadnamePV(names[ix])  )) {
2469                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2470                 }
2471                 else {
2472                     /* save temporaries on recursion? */
2473                     SV * const sv = newSV(0);
2474                     pad1a[ix] = sv;
2475
2476                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2477                        FIXTHAT before merging this branch.
2478                        (And I know how to) */
2479                     if (SvPADMY(oldpad[ix]))
2480                         SvPADMY_on(sv);
2481                     else
2482                         SvPADTMP_on(sv);
2483                 }
2484             }
2485
2486             if (oldpad[0]) {
2487                 args = newAV();                 /* Will be @_ */
2488                 AvREIFY_only(args);
2489                 pad1a[0] = (SV *)args;
2490             }
2491         }
2492     }
2493
2494     return dstpad;
2495 }
2496
2497 #endif /* USE_ITHREADS */
2498
2499 PAD **
2500 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2501 {
2502     PAD **ary;
2503     SSize_t const oldmax = PadlistMAX(padlist);
2504
2505     PERL_ARGS_ASSERT_PADLIST_STORE;
2506
2507     assert(key >= 0);
2508
2509     if (key > PadlistMAX(padlist)) {
2510         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2511                        (SV ***)&PadlistARRAY(padlist),
2512                        (SV ***)&PadlistARRAY(padlist));
2513         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2514              PAD *);
2515     }
2516     ary = PadlistARRAY(padlist);
2517     SvREFCNT_dec(ary[key]);
2518     ary[key] = val;
2519     return &ary[key];
2520 }
2521
2522 /*
2523  * Local variables:
2524  * c-indentation-style: bsd
2525  * c-basic-offset: 4
2526  * indent-tabs-mode: nil
2527  * End:
2528  *
2529  * ex: set ts=8 sts=4 sw=4 et:
2530  */