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