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