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