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