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