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