This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Turn on CVf_LEXICAL for lexical subs
[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])) {
1798                 SvPADTMP_on(PL_curpad[ix]);
1799             } else if (!SvFAKE(namep[ix])) {
1800                 /* This is a work around for how the current implementation of
1801                    ?{ } blocks in regexps interacts with lexicals.
1802
1803                    One of our lexicals.
1804                    Can't do this on all lexicals, otherwise sub baz() won't
1805                    compile in
1806
1807                    my $foo;
1808
1809                    sub bar { ++$foo; }
1810
1811                    sub baz { ++$foo; }
1812
1813                    because completion of compiling &bar calling pad_tidy()
1814                    would cause (top level) $foo to be marked as stale, and
1815                    "no longer available".  */
1816                 SvPADSTALE_on(PL_curpad[ix]);
1817             }
1818         }
1819     }
1820     PL_curpad = AvARRAY(PL_comppad);
1821 }
1822
1823 /*
1824 =for apidoc m|void|pad_free|PADOFFSET po
1825
1826 Free the SV at offset po in the current pad.
1827
1828 =cut
1829 */
1830
1831 /* XXX DAPM integrate with pad_swipe ???? */
1832 void
1833 Perl_pad_free(pTHX_ PADOFFSET po)
1834 {
1835 #ifndef USE_PAD_RESET
1836     SV *sv;
1837 #endif
1838     ASSERT_CURPAD_LEGAL("pad_free");
1839     if (!PL_curpad)
1840         return;
1841     if (AvARRAY(PL_comppad) != PL_curpad)
1842         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1843                    AvARRAY(PL_comppad), PL_curpad);
1844     if (!po)
1845         Perl_croak(aTHX_ "panic: pad_free po");
1846
1847     DEBUG_X(PerlIO_printf(Perl_debug_log,
1848             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1849             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1850     );
1851
1852 #ifndef USE_PAD_RESET
1853     sv = PL_curpad[po];
1854     if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1855         SvFLAGS(sv) &= ~SVs_PADTMP;
1856
1857     if ((I32)po < PL_padix)
1858         PL_padix = po - 1;
1859 #endif
1860 }
1861
1862 /*
1863 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1864
1865 Dump the contents of a padlist
1866
1867 =cut
1868 */
1869
1870 void
1871 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1872 {
1873     const AV *pad_name;
1874     const AV *pad;
1875     SV **pname;
1876     SV **ppad;
1877     I32 ix;
1878
1879     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1880
1881     if (!padlist) {
1882         return;
1883     }
1884     pad_name = *PadlistARRAY(padlist);
1885     pad = PadlistARRAY(padlist)[1];
1886     pname = AvARRAY(pad_name);
1887     ppad = AvARRAY(pad);
1888     Perl_dump_indent(aTHX_ level, file,
1889             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1890             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1891     );
1892
1893     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1894         const SV *namesv = pname[ix];
1895         if (namesv && !PadnameLEN(namesv)) {
1896             namesv = NULL;
1897         }
1898         if (namesv) {
1899             if (SvFAKE(namesv))
1900                 Perl_dump_indent(aTHX_ level+1, file,
1901                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1902                     (int) ix,
1903                     PTR2UV(ppad[ix]),
1904                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1905                     SvPVX_const(namesv),
1906                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1907                     (unsigned long)PARENT_PAD_INDEX(namesv)
1908
1909                 );
1910             else
1911                 Perl_dump_indent(aTHX_ level+1, file,
1912                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1913                     (int) ix,
1914                     PTR2UV(ppad[ix]),
1915                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1916                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1917                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1918                     SvPVX_const(namesv)
1919                 );
1920         }
1921         else if (full) {
1922             Perl_dump_indent(aTHX_ level+1, file,
1923                 "%2d. 0x%"UVxf"<%lu>\n",
1924                 (int) ix,
1925                 PTR2UV(ppad[ix]),
1926                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1927             );
1928         }
1929     }
1930 }
1931
1932 #ifdef DEBUGGING
1933
1934 /*
1935 =for apidoc m|void|cv_dump|CV *cv|const char *title
1936
1937 dump the contents of a CV
1938
1939 =cut
1940 */
1941
1942 STATIC void
1943 S_cv_dump(pTHX_ const CV *cv, const char *title)
1944 {
1945     const CV * const outside = CvOUTSIDE(cv);
1946     PADLIST* const padlist = CvPADLIST(cv);
1947
1948     PERL_ARGS_ASSERT_CV_DUMP;
1949
1950     PerlIO_printf(Perl_debug_log,
1951                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1952                   title,
1953                   PTR2UV(cv),
1954                   (CvANON(cv) ? "ANON"
1955                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1956                    : (cv == PL_main_cv) ? "MAIN"
1957                    : CvUNIQUE(cv) ? "UNIQUE"
1958                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1959                   PTR2UV(outside),
1960                   (!outside ? "null"
1961                    : CvANON(outside) ? "ANON"
1962                    : (outside == PL_main_cv) ? "MAIN"
1963                    : CvUNIQUE(outside) ? "UNIQUE"
1964                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1965
1966     PerlIO_printf(Perl_debug_log,
1967                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1968     do_dump_pad(1, Perl_debug_log, padlist, 1);
1969 }
1970
1971 #endif /* DEBUGGING */
1972
1973 /*
1974 =for apidoc Am|CV *|cv_clone|CV *proto
1975
1976 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1977 of the function: its code, pad structure, and other attributes.
1978 The prototype is combined with a capture of outer lexicals to which the
1979 code refers, which are taken from the currently-executing instance of
1980 the immediately surrounding code.
1981
1982 =cut
1983 */
1984
1985 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1986
1987 static void
1988 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1989 {
1990     I32 ix;
1991     PADLIST* const protopadlist = CvPADLIST(proto);
1992     PAD *const protopad_name = *PadlistARRAY(protopadlist);
1993     const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1994     SV** const pname = AvARRAY(protopad_name);
1995     SV** const ppad = AvARRAY(protopad);
1996     const I32 fname = AvFILLp(protopad_name);
1997     const I32 fpad = AvFILLp(protopad);
1998     SV** outpad;
1999     long depth;
2000     bool subclones = FALSE;
2001
2002     assert(!CvUNIQUE(proto));
2003
2004     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2005      * reliable.  The currently-running sub is always the one we need to
2006      * close over.
2007      * For my subs, the currently-running sub may not be the one we want.
2008      * We have to check whether it is a clone of CvOUTSIDE.
2009      * Note that in general for formats, CvOUTSIDE != find_runcv.
2010      * Since formats may be nested inside closures, CvOUTSIDE may point
2011      * to a prototype; we instead want the cloned parent who called us.
2012      */
2013
2014     if (!outside) {
2015       if (CvWEAKOUTSIDE(proto))
2016         outside = find_runcv(NULL);
2017       else {
2018         outside = CvOUTSIDE(proto);
2019         if ((CvCLONE(outside) && ! CvCLONED(outside))
2020             || !CvPADLIST(outside)
2021             || PadlistNAMES(CvPADLIST(outside))
2022                  != protopadlist->xpadl_outid) {
2023             outside = find_runcv_where(
2024                 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2025             );
2026             /* outside could be null */
2027         }
2028       }
2029     }
2030     depth = outside ? CvDEPTH(outside) : 0;
2031     if (!depth)
2032         depth = 1;
2033
2034     ENTER;
2035     SAVESPTR(PL_compcv);
2036     PL_compcv = cv;
2037     if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2038
2039     if (CvHASEVAL(cv))
2040         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2041
2042     SAVESPTR(PL_comppad_name);
2043     PL_comppad_name = protopad_name;
2044     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2045
2046     av_fill(PL_comppad, fpad);
2047
2048     PL_curpad = AvARRAY(PL_comppad);
2049
2050     outpad = outside && CvPADLIST(outside)
2051         ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2052         : NULL;
2053     if (outpad)
2054         CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2055
2056     for (ix = fpad; ix > 0; ix--) {
2057         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2058         SV *sv = NULL;
2059         if (namesv && PadnameLEN(namesv)) { /* lexical */
2060           if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2061                 NOOP;
2062           }
2063           else {
2064             if (SvFAKE(namesv)) {   /* lexical from outside? */
2065                 /* formats may have an inactive, or even undefined, parent;
2066                    but state vars are always available. */
2067                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2068                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2069                     && (!outside || !CvDEPTH(outside)))  ) {
2070                     S_unavailable(aTHX_ namesv);
2071                     sv = NULL;
2072                 }
2073                 else 
2074                     SvREFCNT_inc_simple_void_NN(sv);
2075             }
2076             if (!sv) {
2077                 const char sigil = SvPVX_const(namesv)[0];
2078                 if (sigil == '&')
2079                     /* If there are state subs, we need to clone them, too.
2080                        But they may need to close over variables we have
2081                        not cloned yet.  So we will have to do a second
2082                        pass.  Furthermore, there may be state subs clos-
2083                        ing over other state subs’ entries, so we have
2084                        to put a stub here and then clone into it on the
2085                        second pass. */
2086                     if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2087                         assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2088                         subclones = 1;
2089                         sv = newSV_type(SVt_PVCV);
2090                         CvLEXICAL_on(sv);
2091                     }
2092                     else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2093                     {
2094                         /* my sub */
2095                         /* Just provide a stub, but name it.  It will be
2096                            upgrade to the real thing on scope entry. */
2097                         dVAR;
2098                         U32 hash;
2099                         PERL_HASH(hash, SvPVX_const(namesv)+1,
2100                                   SvCUR(namesv) - 1);
2101                         sv = newSV_type(SVt_PVCV);
2102                         CvNAME_HEK_set(
2103                             sv,
2104                             share_hek(SvPVX_const(namesv)+1,
2105                                       SvCUR(namesv) - 1
2106                                          * (SvUTF8(namesv) ? -1 : 1),
2107                                       hash)
2108                         );
2109                         CvLEXICAL_on(sv);
2110                     }
2111                     else sv = SvREFCNT_inc(ppad[ix]);
2112                 else if (sigil == '@')
2113                     sv = MUTABLE_SV(newAV());
2114                 else if (sigil == '%')
2115                     sv = MUTABLE_SV(newHV());
2116                 else
2117                     sv = newSV(0);
2118                 SvPADMY_on(sv);
2119                 /* reset the 'assign only once' flag on each state var */
2120                 if (sigil != '&' && SvPAD_STATE(namesv))
2121                     SvPADSTALE_on(sv);
2122             }
2123           }
2124         }
2125         else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2126             sv = SvREFCNT_inc_NN(ppad[ix]);
2127         }
2128         else {
2129             sv = newSV(0);
2130             SvPADTMP_on(sv);
2131         }
2132         PL_curpad[ix] = sv;
2133     }
2134
2135     if (subclones)
2136         for (ix = fpad; ix > 0; ix--) {
2137             SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2138             if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2139              && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2140                 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2141         }
2142
2143     if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2144     LEAVE;
2145 }
2146
2147 static CV *
2148 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2149 {
2150 #ifdef USE_ITHREADS
2151     dVAR;
2152 #endif
2153     const bool newcv = !cv;
2154
2155     assert(!CvUNIQUE(proto));
2156
2157     if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2158     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2159                                     |CVf_SLABBED);
2160     CvCLONED_on(cv);
2161
2162     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2163                                            : CvFILE(proto);
2164     if (CvNAMED(proto))
2165          CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2166     else CvGV_set(cv,CvGV(proto));
2167     CvSTASH_set(cv, CvSTASH(proto));
2168     OP_REFCNT_LOCK;
2169     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
2170     OP_REFCNT_UNLOCK;
2171     CvSTART(cv)         = CvSTART(proto);
2172     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2173
2174     if (SvPOK(proto)) {
2175         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2176         if (SvUTF8(proto))
2177            SvUTF8_on(MUTABLE_SV(cv));
2178     }
2179     if (SvMAGIC(proto))
2180         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2181
2182     if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2183
2184     DEBUG_Xv(
2185         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2186         if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2187         cv_dump(proto,   "Proto");
2188         cv_dump(cv,      "To");
2189     );
2190
2191     if (CvCONST(cv)) {
2192         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2193          * The prototype was marked as a candiate for const-ization,
2194          * so try to grab the current const value, and if successful,
2195          * turn into a const sub:
2196          */
2197         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2198         if (const_sv) {
2199             SvREFCNT_dec_NN(cv);
2200             /* For this calling case, op_const_sv returns a *copy*, which we
2201                donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2202                Need to fix how lib/constant.pm works to eliminate this.  */
2203             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2204         }
2205         else {
2206             CvCONST_off(cv);
2207         }
2208     }
2209
2210     return cv;
2211 }
2212
2213 CV *
2214 Perl_cv_clone(pTHX_ CV *proto)
2215 {
2216     PERL_ARGS_ASSERT_CV_CLONE;
2217
2218     if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2219     return S_cv_clone(aTHX_ proto, NULL, NULL);
2220 }
2221
2222 /* Called only by pp_clonecv */
2223 CV *
2224 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2225 {
2226     PERL_ARGS_ASSERT_CV_CLONE_INTO;
2227     cv_undef(target);
2228     return S_cv_clone(aTHX_ proto, target, NULL);
2229 }
2230
2231 /*
2232 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2233
2234 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2235 old_cv to new_cv if necessary.  Needed when a newly-compiled CV has to be
2236 moved to a pre-existing CV struct.
2237
2238 =cut
2239 */
2240
2241 void
2242 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2243 {
2244     I32 ix;
2245     AV * const comppad_name = PadlistARRAY(padlist)[0];
2246     AV * const comppad = PadlistARRAY(padlist)[1];
2247     SV ** const namepad = AvARRAY(comppad_name);
2248     SV ** const curpad = AvARRAY(comppad);
2249
2250     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2251     PERL_UNUSED_ARG(old_cv);
2252
2253     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2254         const SV * const namesv = namepad[ix];
2255         if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2256             && *SvPVX_const(namesv) == '&')
2257         {
2258           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2259             MAGIC * const mg =
2260                 SvMAGICAL(curpad[ix])
2261                     ? mg_find(curpad[ix], PERL_MAGIC_proto)
2262                     : NULL;
2263             CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2264             if (CvOUTSIDE(innercv) == old_cv) {
2265                 if (!CvWEAKOUTSIDE(innercv)) {
2266                     SvREFCNT_dec(old_cv);
2267                     SvREFCNT_inc_simple_void_NN(new_cv);
2268                 }
2269                 CvOUTSIDE(innercv) = new_cv;
2270             }
2271           }
2272           else { /* format reference */
2273             SV * const rv = curpad[ix];
2274             CV *innercv;
2275             if (!SvOK(rv)) continue;
2276             assert(SvROK(rv));
2277             assert(SvWEAKREF(rv));
2278             innercv = (CV *)SvRV(rv);
2279             assert(!CvWEAKOUTSIDE(innercv));
2280             SvREFCNT_dec(CvOUTSIDE(innercv));
2281             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2282           }
2283         }
2284     }
2285 }
2286
2287 /*
2288 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2289
2290 Push a new pad frame onto the padlist, unless there's already a pad at
2291 this depth, in which case don't bother creating a new one.  Then give
2292 the new pad an @_ in slot zero.
2293
2294 =cut
2295 */
2296
2297 void
2298 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2299 {
2300     PERL_ARGS_ASSERT_PAD_PUSH;
2301
2302     if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2303         PAD** const svp = PadlistARRAY(padlist);
2304         AV* const newpad = newAV();
2305         SV** const oldpad = AvARRAY(svp[depth-1]);
2306         I32 ix = AvFILLp((const AV *)svp[1]);
2307         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2308         SV** const names = AvARRAY(svp[0]);
2309         AV *av;
2310
2311         for ( ;ix > 0; ix--) {
2312             if (names_fill >= ix && PadnameLEN(names[ix])) {
2313                 const char sigil = SvPVX_const(names[ix])[0];
2314                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2315                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2316                         || sigil == '&')
2317                 {
2318                     /* outer lexical or anon code */
2319                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2320                 }
2321                 else {          /* our own lexical */
2322                     SV *sv; 
2323                     if (sigil == '@')
2324                         sv = MUTABLE_SV(newAV());
2325                     else if (sigil == '%')
2326                         sv = MUTABLE_SV(newHV());
2327                     else
2328                         sv = newSV(0);
2329                     av_store(newpad, ix, sv);
2330                     SvPADMY_on(sv);
2331                 }
2332             }
2333             else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2334                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2335             }
2336             else {
2337                 /* save temporaries on recursion? */
2338                 SV * const sv = newSV(0);
2339                 av_store(newpad, ix, sv);
2340                 SvPADTMP_on(sv);
2341             }
2342         }
2343         av = newAV();
2344         av_store(newpad, 0, MUTABLE_SV(av));
2345         AvREIFY_only(av);
2346
2347         padlist_store(padlist, depth, newpad);
2348     }
2349 }
2350
2351 /*
2352 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2353
2354 Looks up the type of the lexical variable at position I<po> in the
2355 currently-compiling pad.  If the variable is typed, the stash of the
2356 class to which it is typed is returned.  If not, C<NULL> is returned.
2357
2358 =cut
2359 */
2360
2361 HV *
2362 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2363 {
2364     SV* const av = PAD_COMPNAME_SV(po);
2365     if ( SvPAD_TYPED(av) ) {
2366         return SvSTASH(av);
2367     }
2368     return NULL;
2369 }
2370
2371 #if defined(USE_ITHREADS)
2372
2373 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2374
2375 /*
2376 =for apidoc padlist_dup
2377
2378 Duplicates a pad.
2379
2380 =cut
2381 */
2382
2383 PADLIST *
2384 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2385 {
2386     PADLIST *dstpad;
2387     bool cloneall;
2388     PADOFFSET max;
2389
2390     PERL_ARGS_ASSERT_PADLIST_DUP;
2391
2392     if (!srcpad)
2393         return NULL;
2394
2395     cloneall = param->flags & CLONEf_COPY_STACKS
2396         || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2397     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2398
2399     max = cloneall ? PadlistMAX(srcpad) : 1;
2400
2401     Newx(dstpad, 1, PADLIST);
2402     ptr_table_store(PL_ptr_table, srcpad, dstpad);
2403     PadlistMAX(dstpad) = max;
2404     Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2405
2406     if (cloneall) {
2407         PADOFFSET depth;
2408         for (depth = 0; depth <= max; ++depth)
2409             PadlistARRAY(dstpad)[depth] =
2410                 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2411     } else {
2412         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2413            to build anything other than the first level of pads.  */
2414         I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2415         AV *pad1;
2416         const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2417         const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2418         SV **oldpad = AvARRAY(srcpad1);
2419         SV **names;
2420         SV **pad1a;
2421         AV *args;
2422
2423         PadlistARRAY(dstpad)[0] =
2424             av_dup_inc(PadlistARRAY(srcpad)[0], param);
2425         names = AvARRAY(PadlistARRAY(dstpad)[0]);
2426
2427         pad1 = newAV();
2428
2429         av_extend(pad1, ix);
2430         PadlistARRAY(dstpad)[1] = pad1;
2431         pad1a = AvARRAY(pad1);
2432
2433         if (ix > -1) {
2434             AvFILLp(pad1) = ix;
2435
2436             for ( ;ix > 0; ix--) {
2437                 if (!oldpad[ix]) {
2438                     pad1a[ix] = NULL;
2439                 } else if (names_fill >= ix && names[ix] &&
2440                            PadnameLEN(names[ix])) {
2441                     const char sigil = SvPVX_const(names[ix])[0];
2442                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2443                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2444                         || sigil == '&')
2445                         {
2446                             /* outer lexical or anon code */
2447                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2448                         }
2449                     else {              /* our own lexical */
2450                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2451                             /* This is a work around for how the current
2452                                implementation of ?{ } blocks in regexps
2453                                interacts with lexicals.  */
2454                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2455                         } else {
2456                             SV *sv; 
2457                             
2458                             if (sigil == '@')
2459                                 sv = MUTABLE_SV(newAV());
2460                             else if (sigil == '%')
2461                                 sv = MUTABLE_SV(newHV());
2462                             else
2463                                 sv = newSV(0);
2464                             pad1a[ix] = sv;
2465                             SvPADMY_on(sv);
2466                         }
2467                     }
2468                 }
2469                 else if (IS_PADGV(oldpad[ix])
2470                       || (  names_fill >= ix && names[ix]
2471                          && PadnamePV(names[ix])  )) {
2472                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2473                 }
2474                 else {
2475                     /* save temporaries on recursion? */
2476                     SV * const sv = newSV(0);
2477                     pad1a[ix] = sv;
2478
2479                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2480                        FIXTHAT before merging this branch.
2481                        (And I know how to) */
2482                     if (SvPADMY(oldpad[ix]))
2483                         SvPADMY_on(sv);
2484                     else
2485                         SvPADTMP_on(sv);
2486                 }
2487             }
2488
2489             if (oldpad[0]) {
2490                 args = newAV();                 /* Will be @_ */
2491                 AvREIFY_only(args);
2492                 pad1a[0] = (SV *)args;
2493             }
2494         }
2495     }
2496
2497     return dstpad;
2498 }
2499
2500 #endif /* USE_ITHREADS */
2501
2502 PAD **
2503 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2504 {
2505     PAD **ary;
2506     SSize_t const oldmax = PadlistMAX(padlist);
2507
2508     PERL_ARGS_ASSERT_PADLIST_STORE;
2509
2510     assert(key >= 0);
2511
2512     if (key > PadlistMAX(padlist)) {
2513         av_extend_guts(NULL,key,&PadlistMAX(padlist),
2514                        (SV ***)&PadlistARRAY(padlist),
2515                        (SV ***)&PadlistARRAY(padlist));
2516         Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2517              PAD *);
2518     }
2519     ary = PadlistARRAY(padlist);
2520     SvREFCNT_dec(ary[key]);
2521     ary[key] = val;
2522     return &ary[key];
2523 }
2524
2525 /*
2526  * Local variables:
2527  * c-indentation-style: bsd
2528  * c-basic-offset: 4
2529  * indent-tabs-mode: nil
2530  * End:
2531  *
2532  * ex: set ts=8 sts=4 sw=4 et:
2533  */