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