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