This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2f62504a3fffa809a7c2f328c74c0d28b853c86d
[perl5.git] / pad.c
1 /*    pad.c
2  *
3  *    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4  *    by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  */
9
10 /*
11  *  'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12  *   might say, among those queer Bucklanders, being brought up anyhow in
13  *   Brandy Hall.  A regular warren, by all accounts.  Old Master Gorbadoc
14  *   never had fewer than a couple of hundred relations in the place.
15  *   Mr. Bilbo never did a kinder deed than when he brought the lad back
16  *   to live among decent folk.'                           --the Gaffer
17  *
18  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
19  */
20
21 /* XXX DAPM
22  * As of Sept 2002, this file is new and may be in a state of flux for
23  * a while. I've marked things I intent to come back and look at further
24  * with an 'XXX DAPM' comment.
25  */
26
27 /*
28 =head1 Pad Data Structures
29
30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
31
32 CV's can have CvPADLIST(cv) set to point to a PADLIST.  This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
34 per-thread values.
35
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing).  Require'd files are simply evals without any outer lexical
39 scope.
40
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub).
44
45 The PADLIST has a C array where pads are stored.
46
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals.  The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change).  Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it.  See L</PadlistNAMES>.
53
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV.  The 0th slot of a frame AV is an
56 AV which is @_.  Other entries are storage for variables and op targets.
57
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items.  Pad slots for targets (SVs_PADTMP)
60 and GVs end up having &PL_sv_undef
61 "names", while slots for constants have &PL_sv_no "names" (see
62 pad_alloc()).  That &PL_sv_no is used is an implementation detail subject
63 to change.  To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
64
65 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
66 The rest are op targets/GVs/constants which are statically allocated
67 or resolved at compile time.  These don't have names by which they
68 can be looked up from Perl code at run time through eval"" the way
69 my/our variables can be.  Since they can't be looked up by "name"
70 but only by their index allocated at compile time (which is usually
71 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
72
73 The SVs in the names AV have their PV being the name of the variable.
74 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
75 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
76 _HIGH).  During compilation, these fields may hold the special value
77 PERL_PADSEQ_INTRO to indicate various stages:
78
79    COP_SEQ_RANGE_LOW        _HIGH
80    -----------------        -----
81    PERL_PADSEQ_INTRO            0   variable not yet introduced:   { my ($x
82    valid-seq#   PERL_PADSEQ_INTRO   variable in scope:             { my ($x)
83    valid-seq#          valid-seq#   compilation of scope complete: { my ($x) }
84
85 For typed lexicals name SV is SVt_PVMG and SvSTASH
86 points at the type.  For C<our> lexicals, the type is also SVt_PVMG, with the
87 SvOURSTASH slot pointing at the stash of the associated global (so that
88 duplicate C<our> declarations in the same package can be detected).  SvUVX is
89 sometimes hijacked to store the generation number during compilation.
90
91 If PADNAME_OUTER (SvFAKE) is set on the
92 name SV, then that slot in the frame AV is
93 a REFCNT'ed reference to a lexical from "outside".  In this case,
94 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
95 in scope throughout.  Instead xhigh stores some flags containing info about
96 the real lexical (is it declared in an anon, and is it capable of being
97 instantiated multiple times?), and for fake ANONs, xlow contains the index
98 within the parent's pad where the lexical's value is stored, to make
99 cloning quicker.
100
101 If the 'name' is '&' the corresponding entry in the PAD
102 is a CV representing a possible closure.
103 (PADNAME_OUTER and name of '&' is not a
104 meaningful combination currently but could
105 become so if C<my sub foo {}> is implemented.)
106
107 Note that formats are treated as anon subs, and are cloned each time
108 write is called (if necessary).
109
110 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
111 and set on scope exit.  This allows the
112 'Variable $x is not available' warning
113 to be generated in evals, such as 
114
115     { my $x = 1; sub f { eval '$x'} } f();
116
117 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
118
119 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
120
121 During compilation, this points to the array containing the names part
122 of the pad for the currently-compiling code.
123
124 =for apidoc AmxU|PAD *|PL_comppad
125
126 During compilation, this points to the array containing the values
127 part of the pad for the currently-compiling code.  (At runtime a CV may
128 have many such value arrays; at compile time just one is constructed.)
129 At runtime, this points to the array containing the currently-relevant
130 values for the pad for the currently-executing code.
131
132 =for apidoc AmxU|SV **|PL_curpad
133
134 Points directly to the body of the L</PL_comppad> array.
135 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
136
137 =cut
138 */
139
140
141 #include "EXTERN.h"
142 #define PERL_IN_PAD_C
143 #include "perl.h"
144 #include "keywords.h"
145
146 #define COP_SEQ_RANGE_LOW_set(sv,val)           \
147   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
148 #define COP_SEQ_RANGE_HIGH_set(sv,val)          \
149   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
150
151 #define PARENT_PAD_INDEX_set(sv,val)            \
152   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
153 #define PARENT_FAKELEX_FLAGS_set(sv,val)        \
154   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
155
156 /*
157 This is basically sv_eq_flags() in sv.c, but we avoid the magic
158 and bytes checking.
159 */
160
161 static bool
162 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
163     if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
164         const char *pv1 = SvPVX_const(sv);
165         STRLEN cur1     = SvCUR(sv);
166         const char *pv2 = pv;
167         STRLEN cur2     = pvlen;
168         if (PL_encoding) {
169               SV* svrecode = NULL;
170               if (SvUTF8(sv)) {
171                    svrecode = newSVpvn(pv2, cur2);
172                    sv_recode_to_utf8(svrecode, PL_encoding);
173                    pv2      = SvPV_const(svrecode, cur2);
174               }
175               else {
176                    svrecode = newSVpvn(pv1, cur1);
177                    sv_recode_to_utf8(svrecode, PL_encoding);
178                    pv1      = SvPV_const(svrecode, cur1);
179               }
180               SvREFCNT_dec_NN(svrecode);
181         }
182         if (flags & SVf_UTF8)
183             return (bytes_cmp_utf8(
184                         (const U8*)pv1, cur1,
185                         (const U8*)pv2, cur2) == 0);
186         else
187             return (bytes_cmp_utf8(
188                         (const U8*)pv2, cur2,
189                         (const U8*)pv1, cur1) == 0);
190     }
191     else
192         return ((SvPVX_const(sv) == pv)
193                     || memEQ(SvPVX_const(sv), pv, pvlen));
194 }
195
196
197 /*
198 =for apidoc Am|PADLIST *|pad_new|int flags
199
200 Create a new padlist, updating the global variables for the
201 currently-compiling padlist to point to the new padlist.  The following
202 flags can be OR'ed together:
203
204     padnew_CLONE        this pad is for a cloned CV
205     padnew_SAVE         save old globals on the save stack
206     padnew_SAVESUB      also save extra stuff for start of sub
207
208 =cut
209 */
210
211 PADLIST *
212 Perl_pad_new(pTHX_ int flags)
213 {
214     PADLIST *padlist;
215     PAD *padname, *pad;
216     PAD **ary;
217
218     ASSERT_CURPAD_LEGAL("pad_new");
219
220     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
221      * vars (based on flags) rather than storing vals + addresses for
222      * each individually. Also see pad_block_start.
223      * XXX DAPM Try to see whether all these conditionals are required
224      */
225
226     /* save existing state, ... */
227
228     if (flags & padnew_SAVE) {
229         SAVECOMPPAD();
230         if (! (flags & padnew_CLONE)) {
231             SAVESPTR(PL_comppad_name);
232             SAVEI32(PL_padix);
233             SAVEI32(PL_constpadix);
234             SAVEI32(PL_comppad_name_fill);
235             SAVEI32(PL_min_intro_pending);
236             SAVEI32(PL_max_intro_pending);
237             SAVEBOOL(PL_cv_has_eval);
238             if (flags & padnew_SAVESUB) {
239                 SAVEBOOL(PL_pad_reset_pending);
240             }
241         }
242     }
243     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
244      * saved - check at some pt that this is okay */
245
246     /* ... create new pad ... */
247
248     Newxz(padlist, 1, PADLIST);
249     pad         = newAV();
250
251     if (flags & padnew_CLONE) {
252         /* XXX DAPM  I dont know why cv_clone needs it
253          * doing differently yet - perhaps this separate branch can be
254          * dispensed with eventually ???
255          */
256
257         AV * const a0 = newAV();                        /* will be @_ */
258         av_store(pad, 0, MUTABLE_SV(a0));
259         AvREIFY_only(a0);
260
261         padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
262     }
263     else {
264         av_store(pad, 0, NULL);
265         padname = newAV();
266         AvPAD_NAMELIST_on(padname);
267         av_store(padname, 0, &PL_sv_undef);
268     }
269
270     /* Most subroutines never recurse, hence only need 2 entries in the padlist
271        array - names, and depth=1.  The default for av_store() is to allocate
272        0..3, and even an explicit call to av_extend() with <3 will be rounded
273        up, so we inline the allocation of the array here.  */
274     Newx(ary, 2, PAD *);
275     PadlistMAX(padlist) = 1;
276     PadlistARRAY(padlist) = ary;
277     ary[0] = padname;
278     ary[1] = pad;
279
280     /* ... then update state variables */
281
282     PL_comppad          = pad;
283     PL_curpad           = AvARRAY(pad);
284
285     if (! (flags & padnew_CLONE)) {
286         PL_comppad_name      = padname;
287         PL_comppad_name_fill = 0;
288         PL_min_intro_pending = 0;
289         PL_padix             = 0;
290         PL_constpadix        = 0;
291         PL_cv_has_eval       = 0;
292     }
293
294     DEBUG_X(PerlIO_printf(Perl_debug_log,
295           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
296               " name=0x%"UVxf" flags=0x%"UVxf"\n",
297           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
298               PTR2UV(padname), (UV)flags
299         )
300     );
301
302     return (PADLIST*)padlist;
303 }
304
305
306 /*
307 =head1 Embedding Functions
308
309 =for apidoc cv_undef
310
311 Clear out all the active components of a CV.  This can happen either
312 by an explicit C<undef &foo>, or by the reference count going to zero.
313 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
314 children can still follow the full lexical scope chain.
315
316 =cut
317 */
318
319 void
320 Perl_cv_undef(pTHX_ CV *cv)
321 {
322     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                  || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1806                 continue;
1807             if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
1808                 /* This is a work around for how the current implementation of
1809                    ?{ } blocks in regexps interacts with lexicals.
1810
1811                    One of our lexicals.
1812                    Can't do this on all lexicals, otherwise sub baz() won't
1813                    compile in
1814
1815                    my $foo;
1816
1817                    sub bar { ++$foo; }
1818
1819                    sub baz { ++$foo; }
1820
1821                    because completion of compiling &bar calling pad_tidy()
1822                    would cause (top level) $foo to be marked as stale, and
1823                    "no longer available".  */
1824                 SvPADSTALE_on(PL_curpad[ix]);
1825             }
1826         }
1827     }
1828     PL_curpad = AvARRAY(PL_comppad);
1829 }
1830
1831 /*
1832 =for apidoc m|void|pad_free|PADOFFSET po
1833
1834 Free the SV at offset po in the current pad.
1835
1836 =cut
1837 */
1838
1839 /* XXX DAPM integrate with pad_swipe ???? */
1840 void
1841 Perl_pad_free(pTHX_ PADOFFSET po)
1842 {
1843 #ifndef USE_PAD_RESET
1844     SV *sv;
1845 #endif
1846     ASSERT_CURPAD_LEGAL("pad_free");
1847     if (!PL_curpad)
1848         return;
1849     if (AvARRAY(PL_comppad) != PL_curpad)
1850         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1851                    AvARRAY(PL_comppad), PL_curpad);
1852     if (!po)
1853         Perl_croak(aTHX_ "panic: pad_free po");
1854
1855     DEBUG_X(PerlIO_printf(Perl_debug_log,
1856             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1857             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1858     );
1859
1860 #ifndef USE_PAD_RESET
1861     sv = PL_curpad[po];
1862     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1863         SvFLAGS(sv) &= ~SVs_PADTMP;
1864
1865     if ((I32)po < PL_padix)
1866         PL_padix = po - 1;
1867 #endif
1868 }
1869
1870 /*
1871 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1872
1873 Dump the contents of a padlist
1874
1875 =cut
1876 */
1877
1878 void
1879 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1880 {
1881     const AV *pad_name;
1882     const AV *pad;
1883     SV **pname;
1884     SV **ppad;
1885     I32 ix;
1886
1887     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1888
1889     if (!padlist) {
1890         return;
1891     }
1892     pad_name = *PadlistARRAY(padlist);
1893     pad = PadlistARRAY(padlist)[1];
1894     pname = AvARRAY(pad_name);
1895     ppad = AvARRAY(pad);
1896     Perl_dump_indent(aTHX_ level, file,
1897             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1898             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1899     );
1900
1901     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1902         const SV *namesv = pname[ix];
1903         if (namesv && !PadnameLEN(namesv)) {
1904             namesv = NULL;
1905         }
1906         if (namesv) {
1907             if (SvFAKE(namesv))
1908                 Perl_dump_indent(aTHX_ level+1, file,
1909                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1910                     (int) ix,
1911                     PTR2UV(ppad[ix]),
1912                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1913                     SvPVX_const(namesv),
1914                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1915                     (unsigned long)PARENT_PAD_INDEX(namesv)
1916
1917                 );
1918             else
1919                 Perl_dump_indent(aTHX_ level+1, file,
1920                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1921                     (int) ix,
1922                     PTR2UV(ppad[ix]),
1923                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1924                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1925                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1926                     SvPVX_const(namesv)
1927                 );
1928         }
1929         else if (full) {
1930             Perl_dump_indent(aTHX_ level+1, file,
1931                 "%2d. 0x%"UVxf"<%lu>\n",
1932                 (int) ix,
1933                 PTR2UV(ppad[ix]),
1934                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1935             );
1936         }
1937     }
1938 }
1939
1940 #ifdef DEBUGGING
1941
1942 /*
1943 =for apidoc m|void|cv_dump|CV *cv|const char *title
1944
1945 dump the contents of a CV
1946
1947 =cut
1948 */
1949
1950 STATIC void
1951 S_cv_dump(pTHX_ const CV *cv, const char *title)
1952 {
1953     const CV * const outside = CvOUTSIDE(cv);
1954     PADLIST* const padlist = CvPADLIST(cv);
1955
1956     PERL_ARGS_ASSERT_CV_DUMP;
1957
1958     PerlIO_printf(Perl_debug_log,
1959                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1960                   title,
1961                   PTR2UV(cv),
1962                   (CvANON(cv) ? "ANON"
1963                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1964                    : (cv == PL_main_cv) ? "MAIN"
1965                    : CvUNIQUE(cv) ? "UNIQUE"
1966                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1967                   PTR2UV(outside),
1968                   (!outside ? "null"
1969                    : CvANON(outside) ? "ANON"
1970                    : (outside == PL_main_cv) ? "MAIN"
1971                    : CvUNIQUE(outside) ? "UNIQUE"
1972                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1973
1974     PerlIO_printf(Perl_debug_log,
1975                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1976     do_dump_pad(1, Perl_debug_log, padlist, 1);
1977 }
1978
1979 #endif /* DEBUGGING */
1980
1981 /*
1982 =for apidoc Am|CV *|cv_clone|CV *proto
1983
1984 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1985 of the function: its code, pad structure, and other attributes.
1986 The prototype is combined with a capture of outer lexicals to which the
1987 code refers, which are taken from the currently-executing instance of
1988 the immediately surrounding code.
1989
1990 =cut
1991 */
1992
1993 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1994
1995 static void
1996 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1997 {
1998     I32 ix;
1999     PADLIST* const protopadlist = CvPADLIST(proto);
2000     PAD *const protopad_name = *PadlistARRAY(protopadlist);
2001     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2002     SV** const pname = AvARRAY(protopad_name);
2003     SV** const ppad = AvARRAY(protopad);
2004     const I32 fname = AvFILLp(protopad_name);
2005     const I32 fpad = AvFILLp(protopad);
2006     SV** outpad;
2007     long depth;
2008     bool subclones = FALSE;
2009
2010     assert(!CvUNIQUE(proto));
2011
2012     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2013      * reliable.  The currently-running sub is always the one we need to
2014      * close over.
2015      * For my subs, the currently-running sub may not be the one we want.
2016      * We have to check whether it is a clone of CvOUTSIDE.
2017      * Note that in general for formats, CvOUTSIDE != find_runcv.
2018      * Since formats may be nested inside closures, CvOUTSIDE may point
2019      * to a prototype; we instead want the cloned parent who called us.
2020      */
2021
2022     if (!outside) {
2023       if (CvWEAKOUTSIDE(proto))
2024         outside = find_runcv(NULL);
2025       else {
2026         outside = CvOUTSIDE(proto);
2027         if ((CvCLONE(outside) && ! CvCLONED(outside))
2028             || !CvPADLIST(outside)
2029             || PadlistNAMES(CvPADLIST(outside))
2030                  != protopadlist->xpadl_outid) {
2031             outside = find_runcv_where(
2032                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2033             );
2034             /* outside could be null */
2035         }
2036       }
2037     }
2038     depth = outside ? CvDEPTH(outside) : 0;
2039     if (!depth)
2040         depth = 1;
2041
2042     ENTER;
2043     SAVESPTR(PL_compcv);
2044     PL_compcv = cv;
2045     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2046
2047     if (CvHASEVAL(cv))
2048         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2049
2050     SAVESPTR(PL_comppad_name);
2051     PL_comppad_name = protopad_name;
2052     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2053
2054     av_fill(PL_comppad, fpad);
2055
2056     PL_curpad = AvARRAY(PL_comppad);
2057
2058     outpad = outside && CvPADLIST(outside)
2059         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2060         : NULL;
2061     if (outpad)
2062         CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2063
2064     for (ix = fpad; ix > 0; ix--) {
2065         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2066         SV *sv = NULL;
2067         if (namesv && PadnameLEN(namesv)) { /* lexical */
2068           if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2069                 NOOP;
2070           }
2071           else {
2072             if (SvFAKE(namesv)) {   /* lexical from outside? */
2073                 /* formats may have an inactive, or even undefined, parent;
2074                    but state vars are always available. */
2075                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2076                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2077                     && (!outside || !CvDEPTH(outside)))  ) {
2078                     S_unavailable(aTHX_ namesv);
2079                     sv = NULL;
2080                 }
2081                 else 
2082                     SvREFCNT_inc_simple_void_NN(sv);
2083             }
2084             if (!sv) {
2085                 const char sigil = SvPVX_const(namesv)[0];
2086                 if (sigil == '&')
2087                     /* If there are state subs, we need to clone them, too.
2088                        But they may need to close over variables we have
2089                        not cloned yet.  So we will have to do a second
2090                        pass.  Furthermore, there may be state subs clos-
2091                        ing over other state subs’ entries, so we have
2092                        to put a stub here and then clone into it on the
2093                        second pass. */
2094                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2095                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2096                         subclones = 1;
2097                         sv = newSV_type(SVt_PVCV);
2098                         CvLEXICAL_on(sv);
2099                     }
2100                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2101                     {
2102                         /* my sub */
2103                         /* Just provide a stub, but name it.  It will be
2104                            upgrade to the real thing on scope entry. */
2105                         dVAR;
2106                         U32 hash;
2107                         PERL_HASH(hash, SvPVX_const(namesv)+1,
2108                                   SvCUR(namesv) - 1);
2109                         sv = newSV_type(SVt_PVCV);
2110                         CvNAME_HEK_set(
2111                             sv,
2112                             share_hek(SvPVX_const(namesv)+1,
2113                                       SvCUR(namesv) - 1
2114                                          * (SvUTF8(namesv) ? -1 : 1),
2115                                       hash)
2116                         );
2117                         CvLEXICAL_on(sv);
2118                     }
2119                     else sv = SvREFCNT_inc(ppad[ix]);
2120                 else if (sigil == '@')
2121                     sv = MUTABLE_SV(newAV());
2122                 else if (sigil == '%')
2123                     sv = MUTABLE_SV(newHV());
2124                 else
2125                     sv = newSV(0);
2126                 SvPADMY_on(sv);
2127                 /* reset the 'assign only once' flag on each state var */
2128                 if (sigil != '&' && SvPAD_STATE(namesv))
2129                     SvPADSTALE_on(sv);
2130             }
2131           }
2132         }
2133         else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2134             sv = SvREFCNT_inc_NN(ppad[ix]);
2135         }
2136         else {
2137             sv = newSV(0);
2138             SvPADTMP_on(sv);
2139         }
2140         PL_curpad[ix] = sv;
2141     }
2142
2143     if (subclones)
2144         for (ix = fpad; ix > 0; ix--) {
2145             SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2146             if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2147              && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2148                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2149         }
2150
2151     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2152     LEAVE;
2153 }
2154
2155 static CV *
2156 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2157 {
2158 #ifdef USE_ITHREADS
2159     dVAR;
2160 #endif
2161     const bool newcv = !cv;
2162
2163     assert(!CvUNIQUE(proto));
2164
2165     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2166     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2167                                     |CVf_SLABBED);
2168     CvCLONED_on(cv);
2169
2170     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2171                                            : CvFILE(proto);
2172     if (CvNAMED(proto))
2173          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2174     else CvGV_set(cv,CvGV(proto));
2175     CvSTASH_set(cv, CvSTASH(proto));
2176     OP_REFCNT_LOCK;
2177     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2178     OP_REFCNT_UNLOCK;
2179     CvSTART(cv)         = CvSTART(proto);
2180     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2181
2182     if (SvPOK(proto)) {
2183         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2184         if (SvUTF8(proto))
2185            SvUTF8_on(MUTABLE_SV(cv));
2186     }
2187     if (SvMAGIC(proto))
2188         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2189
2190     if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2191
2192     DEBUG_Xv(
2193         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2194         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2195         cv_dump(proto,   "Proto");
2196         cv_dump(cv,      "To");
2197     );
2198
2199     if (CvCONST(cv)) {
2200         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2201          * The prototype was marked as a candiate for const-ization,
2202          * so try to grab the current const value, and if successful,
2203          * turn into a const sub:
2204          */
2205         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2206         if (const_sv) {
2207             SvREFCNT_dec_NN(cv);
2208             /* For this calling case, op_const_sv returns a *copy*, which we
2209                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2210                Need to fix how lib/constant.pm works to eliminate this.  */
2211             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2212         }
2213         else {
2214             CvCONST_off(cv);
2215         }
2216     }
2217
2218     return cv;
2219 }
2220
2221 CV *
2222 Perl_cv_clone(pTHX_ CV *proto)
2223 {
2224     PERL_ARGS_ASSERT_CV_CLONE;
2225
2226     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2227     return S_cv_clone(aTHX_ proto, NULL, NULL);
2228 }
2229
2230 /* Called only by pp_clonecv */
2231 CV *
2232 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2233 {
2234     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2235     cv_undef(target);
2236     return S_cv_clone(aTHX_ proto, target, NULL);
2237 }
2238
2239 /*
2240 =for apidoc cv_name
2241
2242 Returns an SV containing the name of the CV, mainly for use in error
2243 reporting.  The CV may actually be a GV instead, in which case the returned
2244 SV holds the GV's name.  Anything other than a GV or CV is treated as a
2245 string already holding the sub name, but this could change in the future.
2246
2247 An SV may be passed as a second argument.  If so, the name will be assigned
2248 to it and it will be returned.  Otherwise the returned SV will be a new
2249 mortal.
2250
2251 =cut
2252 */
2253
2254 SV *
2255 Perl_cv_name(pTHX_ CV *cv, SV *sv)
2256 {
2257     PERL_ARGS_ASSERT_CV_NAME;
2258     if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2259         if (sv) sv_setsv(sv,(SV *)cv);
2260         return sv ? (sv) : (SV *)cv;
2261     }
2262     {
2263         SV * const retsv = sv ? (sv) : sv_newmortal();
2264         if (SvTYPE(cv) == SVt_PVCV) {
2265             if (CvNAMED(cv)) {
2266                 if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv));
2267                 else {
2268                     sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2269                     sv_catpvs(retsv, "::");
2270                     sv_cathek(retsv, CvNAME_HEK(cv));
2271                 }
2272             }
2273             else if (CvLEXICAL(cv))
2274                 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2275             else gv_efullname3(retsv, CvGV(cv), NULL);
2276         }
2277         else gv_efullname3(retsv,(GV *)cv,NULL);
2278         return retsv;
2279     }
2280 }
2281
2282 /*
2283 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2284
2285 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2286 old_cv to new_cv if necessary.  Needed when a newly-compiled CV has to be
2287 moved to a pre-existing CV struct.
2288
2289 =cut
2290 */
2291
2292 void
2293 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2294 {
2295     I32 ix;
2296     AV * const comppad_name = PadlistARRAY(padlist)[0];
2297     AV * const comppad = PadlistARRAY(padlist)[1];
2298     SV ** const namepad = AvARRAY(comppad_name);
2299     SV ** const curpad = AvARRAY(comppad);
2300
2301     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2302     PERL_UNUSED_ARG(old_cv);
2303
2304     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2305         const SV * const namesv = namepad[ix];
2306         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2307             && *SvPVX_const(namesv) == '&')
2308         {
2309           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2310             MAGIC * const mg =
2311                 SvMAGICAL(curpad[ix])
2312                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2313                     : NULL;
2314             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2315             if (CvOUTSIDE(innercv) == old_cv) {
2316                 if (!CvWEAKOUTSIDE(innercv)) {
2317                     SvREFCNT_dec(old_cv);
2318                     SvREFCNT_inc_simple_void_NN(new_cv);
2319                 }
2320                 CvOUTSIDE(innercv) = new_cv;
2321             }
2322           }
2323           else { /* format reference */
2324             SV * const rv = curpad[ix];
2325             CV *innercv;
2326             if (!SvOK(rv)) continue;
2327             assert(SvROK(rv));
2328             assert(SvWEAKREF(rv));
2329             innercv = (CV *)SvRV(rv);
2330             assert(!CvWEAKOUTSIDE(innercv));
2331             SvREFCNT_dec(CvOUTSIDE(innercv));
2332             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2333           }
2334         }
2335     }
2336 }
2337
2338 /*
2339 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2340
2341 Push a new pad frame onto the padlist, unless there's already a pad at
2342 this depth, in which case don't bother creating a new one.  Then give
2343 the new pad an @_ in slot zero.
2344
2345 =cut
2346 */
2347
2348 void
2349 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2350 {
2351     PERL_ARGS_ASSERT_PAD_PUSH;
2352
2353     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2354         PAD** const svp = PadlistARRAY(padlist);
2355         AV* const newpad = newAV();
2356         SV** const oldpad = AvARRAY(svp[depth-1]);
2357         I32 ix = AvFILLp((const AV *)svp[1]);
2358         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2359         SV** const names = AvARRAY(svp[0]);
2360         AV *av;
2361
2362         for ( ;ix > 0; ix--) {
2363             if (names_fill >= ix && PadnameLEN(names[ix])) {
2364                 const char sigil = SvPVX_const(names[ix])[0];
2365                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2366                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2367                         || sigil == '&')
2368                 {
2369                     /* outer lexical or anon code */
2370                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2371                 }
2372                 else {          /* our own lexical */
2373                     SV *sv; 
2374                     if (sigil == '@')
2375                         sv = MUTABLE_SV(newAV());
2376                     else if (sigil == '%')
2377                         sv = MUTABLE_SV(newHV());
2378                     else
2379                         sv = newSV(0);
2380                     av_store(newpad, ix, sv);
2381                     SvPADMY_on(sv);
2382                 }
2383             }
2384             else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2385                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2386             }
2387             else {
2388                 /* save temporaries on recursion? */
2389                 SV * const sv = newSV(0);
2390                 av_store(newpad, ix, sv);
2391                 SvPADTMP_on(sv);
2392             }
2393         }
2394         av = newAV();
2395         av_store(newpad, 0, MUTABLE_SV(av));
2396         AvREIFY_only(av);
2397
2398         padlist_store(padlist, depth, newpad);
2399     }
2400 }
2401
2402 /*
2403 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2404
2405 Looks up the type of the lexical variable at position I<po> in the
2406 currently-compiling pad.  If the variable is typed, the stash of the
2407 class to which it is typed is returned.  If not, C<NULL> is returned.
2408
2409 =cut
2410 */
2411
2412 HV *
2413 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2414 {
2415     SV* const av = PAD_COMPNAME_SV(po);
2416     if ( SvPAD_TYPED(av) ) {
2417         return SvSTASH(av);
2418     }
2419     return NULL;
2420 }
2421
2422 #if defined(USE_ITHREADS)
2423
2424 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2425
2426 /*
2427 =for apidoc padlist_dup
2428
2429 Duplicates a pad.
2430
2431 =cut
2432 */
2433
2434 PADLIST *
2435 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2436 {
2437     PADLIST *dstpad;
2438     bool cloneall;
2439     PADOFFSET max;
2440
2441     PERL_ARGS_ASSERT_PADLIST_DUP;
2442
2443     if (!srcpad)
2444         return NULL;
2445
2446     cloneall = param->flags & CLONEf_COPY_STACKS
2447         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2448     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2449
2450     max = cloneall ? PadlistMAX(srcpad) : 1;
2451
2452     Newx(dstpad, 1, PADLIST);
2453     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2454     PadlistMAX(dstpad) = max;
2455     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2456
2457     if (cloneall) {
2458         PADOFFSET depth;
2459         for (depth = 0; depth <= max; ++depth)
2460             PadlistARRAY(dstpad)[depth] =
2461                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2462     } else {
2463         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2464            to build anything other than the first level of pads.  */
2465         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2466         AV *pad1;
2467         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2468         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2469         SV **oldpad = AvARRAY(srcpad1);
2470         SV **names;
2471         SV **pad1a;
2472         AV *args;
2473
2474         PadlistARRAY(dstpad)[0] =
2475             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2476         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2477
2478         pad1 = newAV();
2479
2480         av_extend(pad1, ix);
2481         PadlistARRAY(dstpad)[1] = pad1;
2482         pad1a = AvARRAY(pad1);
2483
2484         if (ix > -1) {
2485             AvFILLp(pad1) = ix;
2486
2487             for ( ;ix > 0; ix--) {
2488                 if (!oldpad[ix]) {
2489                     pad1a[ix] = NULL;
2490                 } else if (names_fill >= ix && names[ix] &&
2491                            PadnameLEN(names[ix])) {
2492                     const char sigil = SvPVX_const(names[ix])[0];
2493                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2494                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2495                         || sigil == '&')
2496                         {
2497                             /* outer lexical or anon code */
2498                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2499                         }
2500                     else {              /* our own lexical */
2501                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2502                             /* This is a work around for how the current
2503                                implementation of ?{ } blocks in regexps
2504                                interacts with lexicals.  */
2505                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2506                         } else {
2507                             SV *sv; 
2508                             
2509                             if (sigil == '@')
2510                                 sv = MUTABLE_SV(newAV());
2511                             else if (sigil == '%')
2512                                 sv = MUTABLE_SV(newHV());
2513                             else
2514                                 sv = newSV(0);
2515                             pad1a[ix] = sv;
2516                             SvPADMY_on(sv);
2517                         }
2518                     }
2519                 }
2520                 else if (IS_PADGV(oldpad[ix])
2521                       || (  names_fill >= ix && names[ix]
2522                          && PadnamePV(names[ix])  )) {
2523                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2524                 }
2525                 else {
2526                     /* save temporaries on recursion? */
2527                     SV * const sv = newSV(0);
2528                     pad1a[ix] = sv;
2529
2530                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2531                        FIXTHAT before merging this branch.
2532                        (And I know how to) */
2533                     if (SvPADMY(oldpad[ix]))
2534                         SvPADMY_on(sv);
2535                     else
2536                         SvPADTMP_on(sv);
2537                 }
2538             }
2539
2540             if (oldpad[0]) {
2541                 args = newAV();                 /* Will be @_ */
2542                 AvREIFY_only(args);
2543                 pad1a[0] = (SV *)args;
2544             }
2545         }
2546     }
2547
2548     return dstpad;
2549 }
2550
2551 #endif /* USE_ITHREADS */
2552
2553 PAD **
2554 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2555 {
2556     PAD **ary;
2557     SSize_t const oldmax = PadlistMAX(padlist);
2558
2559     PERL_ARGS_ASSERT_PADLIST_STORE;
2560
2561     assert(key >= 0);
2562
2563     if (key > PadlistMAX(padlist)) {
2564         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2565                        (SV ***)&PadlistARRAY(padlist),
2566                        (SV ***)&PadlistARRAY(padlist));
2567         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2568              PAD *);
2569     }
2570     ary = PadlistARRAY(padlist);
2571     SvREFCNT_dec(ary[key]);
2572     ary[key] = val;
2573     return &ary[key];
2574 }
2575
2576 /*
2577  * Local variables:
2578  * c-indentation-style: bsd
2579  * c-basic-offset: 4
2580  * indent-tabs-mode: nil
2581  * End:
2582  *
2583  * ex: set ts=8 sts=4 sw=4 et:
2584  */