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