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