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