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