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