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