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