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