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