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