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