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