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