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