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