perldelta for 2b42d7ed8
[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 /* And flag whether the incoming name is UTF8 or 8 bit?
656    Could do this either with the +ve/-ve hack of the HV code, or expanding
657    the flag bits. Either way, this makes proper Unicode safe pad support.
658    NWC
659 */
660
661 PADOFFSET
662 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
663 {
664     dVAR;
665     SV *sv;
666     I32 retval;
667
668     PERL_UNUSED_ARG(optype);
669     ASSERT_CURPAD_ACTIVE("pad_alloc");
670
671     if (AvARRAY(PL_comppad) != PL_curpad)
672         Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
673                    AvARRAY(PL_comppad), PL_curpad);
674     if (PL_pad_reset_pending)
675         pad_reset();
676     if (tmptype & SVs_PADMY) {
677         /* For a my, simply push a null SV onto the end of PL_comppad. */
678         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
679         retval = AvFILLp(PL_comppad);
680     }
681     else {
682         /* For a tmp, scan the pad from PL_padix upwards
683          * for a slot which has no name and no active value.
684          */
685         SV * const * const names = AvARRAY(PL_comppad_name);
686         const SSize_t names_fill = AvFILLp(PL_comppad_name);
687         for (;;) {
688             /*
689              * "foreach" index vars temporarily become aliases to non-"my"
690              * values.  Thus we must skip, not just pad values that are
691              * marked as current pad values, but also those with names.
692              */
693             /* HVDS why copy to sv here? we don't seem to use it */
694             if (++PL_padix <= names_fill &&
695                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
696                 continue;
697             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
698             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
699                 !IS_PADGV(sv) && !IS_PADCONST(sv))
700                 break;
701         }
702         retval = PL_padix;
703     }
704     SvFLAGS(sv) |= tmptype;
705     PL_curpad = AvARRAY(PL_comppad);
706
707     DEBUG_X(PerlIO_printf(Perl_debug_log,
708           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
709           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
710           PL_op_name[optype]));
711 #ifdef DEBUG_LEAKING_SCALARS
712     sv->sv_debug_optype = optype;
713     sv->sv_debug_inpad = 1;
714 #endif
715     return (PADOFFSET)retval;
716 }
717
718 /*
719 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
720
721 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
722 for an anonymous function that is lexically scoped inside the
723 currently-compiling function.
724 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
725 to the outer scope is weakened to avoid a reference loop.
726
727 I<optype> should be an opcode indicating the type of operation that the
728 pad entry is to support.  This doesn't affect operational semantics,
729 but is used for debugging.
730
731 =cut
732 */
733
734 PADOFFSET
735 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
736 {
737     dVAR;
738     PADOFFSET ix;
739     SV* const name = newSV_type(SVt_PVNV);
740
741     PERL_ARGS_ASSERT_PAD_ADD_ANON;
742
743     pad_peg("add_anon");
744     sv_setpvs(name, "&");
745     /* These two aren't used; just make sure they're not equal to
746      * PERL_PADSEQ_INTRO */
747     COP_SEQ_RANGE_LOW_set(name, 0);
748     COP_SEQ_RANGE_HIGH_set(name, 0);
749     ix = pad_alloc(optype, SVs_PADMY);
750     av_store(PL_comppad_name, ix, name);
751     /* XXX DAPM use PL_curpad[] ? */
752     av_store(PL_comppad, ix, (SV*)func);
753     SvPADMY_on((SV*)func);
754
755     /* to avoid ref loops, we never have parent + child referencing each
756      * other simultaneously */
757     if (CvOUTSIDE(func)) {
758         assert(!CvWEAKOUTSIDE(func));
759         CvWEAKOUTSIDE_on(func);
760         SvREFCNT_dec(CvOUTSIDE(func));
761     }
762     return ix;
763 }
764
765 /*
766 =for apidoc pad_check_dup
767
768 Check for duplicate declarations: report any of:
769
770      * a my in the current scope with the same name;
771      * an our (anywhere in the pad) with the same name and the
772        same stash as C<ourstash>
773
774 C<is_our> indicates that the name to check is an 'our' declaration.
775
776 =cut
777 */
778
779 STATIC void
780 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
781 {
782     dVAR;
783     SV          **svp;
784     PADOFFSET   top, off;
785     const U32   is_our = flags & padadd_OUR;
786
787     PERL_ARGS_ASSERT_PAD_CHECK_DUP;
788
789     ASSERT_CURPAD_ACTIVE("pad_check_dup");
790
791     assert((flags & ~padadd_OUR) == 0);
792
793     if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
794         return; /* nothing to check */
795
796     svp = AvARRAY(PL_comppad_name);
797     top = AvFILLp(PL_comppad_name);
798     /* check the current scope */
799     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
800      * type ? */
801     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
802         SV * const sv = svp[off];
803         if (sv
804             && sv != &PL_sv_undef
805             && !SvFAKE(sv)
806             && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
807                 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
808             && sv_eq(name, sv))
809         {
810             if (is_our && (SvPAD_OUR(sv)))
811                 break; /* "our" masking "our" */
812             Perl_warner(aTHX_ packWARN(WARN_MISC),
813                 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
814                 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
815                 sv,
816                 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
817                     ? "scope" : "statement"));
818             --off;
819             break;
820         }
821     }
822     /* check the rest of the pad */
823     if (is_our) {
824         while (off > 0) {
825             SV * const sv = svp[off];
826             if (sv
827                 && sv != &PL_sv_undef
828                 && !SvFAKE(sv)
829                 && (   COP_SEQ_RANGE_LOW(sv)  == PERL_PADSEQ_INTRO
830                     || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
831                 && SvOURSTASH(sv) == ourstash
832                 && sv_eq(name, sv))
833             {
834                 Perl_warner(aTHX_ packWARN(WARN_MISC),
835                     "\"our\" variable %"SVf" redeclared", sv);
836                 if ((I32)off <= PL_comppad_name_floor)
837                     Perl_warner(aTHX_ packWARN(WARN_MISC),
838                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
839                 break;
840             }
841             --off;
842         }
843     }
844 }
845
846
847 /*
848 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
849
850 Given the name of a lexical variable, find its position in the
851 currently-compiling pad.
852 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
853 I<flags> is reserved and must be zero.
854 If it is not in the current pad but appears in the pad of any lexically
855 enclosing scope, then a pseudo-entry for it is added in the current pad.
856 Returns the offset in the current pad,
857 or C<NOT_IN_PAD> if no such lexical is in scope.
858
859 =cut
860 */
861
862 PADOFFSET
863 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
864 {
865     dVAR;
866     SV *out_sv;
867     int out_flags;
868     I32 offset;
869     const AV *nameav;
870     SV **name_svp;
871
872     PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
873
874     pad_peg("pad_findmy_pvn");
875
876     if (flags & ~padadd_UTF8_NAME)
877         Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
878                    (UV)flags);
879
880     if (flags & padadd_UTF8_NAME) {
881         bool is_utf8 = TRUE;
882         namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
883
884         if (is_utf8)
885             flags |= padadd_UTF8_NAME;
886         else
887             flags &= ~padadd_UTF8_NAME;
888     }
889
890     offset = pad_findlex(namepv, namelen, flags,
891                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
892     if ((PADOFFSET)offset != NOT_IN_PAD) 
893         return offset;
894
895     /* look for an our that's being introduced; this allows
896      *    our $foo = 0 unless defined $foo;
897      * to not give a warning. (Yes, this is a hack) */
898
899     nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
900     name_svp = AvARRAY(nameav);
901     for (offset = AvFILLp(nameav); offset > 0; offset--) {
902         const SV * const namesv = name_svp[offset];
903         if (namesv && namesv != &PL_sv_undef
904             && !SvFAKE(namesv)
905             && (SvPAD_OUR(namesv))
906             && SvCUR(namesv) == namelen
907             && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
908                                 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
909             && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
910         )
911             return offset;
912     }
913     return NOT_IN_PAD;
914 }
915
916 /*
917 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
918
919 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
920 instead of a string/length pair.
921
922 =cut
923 */
924
925 PADOFFSET
926 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
927 {
928     PERL_ARGS_ASSERT_PAD_FINDMY_PV;
929     return pad_findmy_pvn(name, strlen(name), flags);
930 }
931
932 /*
933 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
934
935 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
936 of an SV instead of a string/length pair.
937
938 =cut
939 */
940
941 PADOFFSET
942 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
943 {
944     char *namepv;
945     STRLEN namelen;
946     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
947     namepv = SvPV(name, namelen);
948     if (SvUTF8(name))
949         flags |= padadd_UTF8_NAME;
950     return pad_findmy_pvn(namepv, namelen, flags);
951 }
952
953 /*
954 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
955
956 Find the position of the lexical C<$_> in the pad of the
957 currently-executing function.  Returns the offset in the current pad,
958 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
959 the global one should be used instead).
960 L</find_rundefsv> is likely to be more convenient.
961
962 =cut
963 */
964
965 PADOFFSET
966 Perl_find_rundefsvoffset(pTHX)
967 {
968     dVAR;
969     SV *out_sv;
970     int out_flags;
971     return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
972             NULL, &out_sv, &out_flags);
973 }
974
975 /*
976 =for apidoc Am|SV *|find_rundefsv
977
978 Find and return the variable that is named C<$_> in the lexical scope
979 of the currently-executing function.  This may be a lexical C<$_>,
980 or will otherwise be the global one.
981
982 =cut
983 */
984
985 SV *
986 Perl_find_rundefsv(pTHX)
987 {
988     SV *namesv;
989     int flags;
990     PADOFFSET po;
991
992     po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
993             NULL, &namesv, &flags);
994
995     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
996         return DEFSV;
997
998     return PAD_SVl(po);
999 }
1000
1001 SV *
1002 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1003 {
1004     SV *namesv;
1005     int flags;
1006     PADOFFSET po;
1007
1008     PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1009
1010     po = pad_findlex("$_", 2, 0, cv, seq, 1,
1011             NULL, &namesv, &flags);
1012
1013     if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1014         return DEFSV;
1015
1016     return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1017 }
1018
1019 /*
1020 =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
1021
1022 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1023 in the inner pads if it's found in an outer one.
1024
1025 Returns the offset in the bottom pad of the lex or the fake lex.
1026 cv is the CV in which to start the search, and seq is the current cop_seq
1027 to match against. If warn is true, print appropriate warnings.  The out_*
1028 vars return values, and so are pointers to where the returned values
1029 should be stored. out_capture, if non-null, requests that the innermost
1030 instance of the lexical is captured; out_name_sv is set to the innermost
1031 matched namesv or fake namesv; out_flags returns the flags normally
1032 associated with the IVX field of a fake namesv.
1033
1034 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1035 then comes back down, adding fake entries as it goes. It has to be this way
1036 because fake namesvs in anon protoypes have to store in xlow the index into
1037 the parent pad.
1038
1039 =cut
1040 */
1041
1042 /* the CV has finished being compiled. This is not a sufficient test for
1043  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1044 #define CvCOMPILED(cv)  CvROOT(cv)
1045
1046 /* the CV does late binding of its lexicals */
1047 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1048
1049
1050 STATIC PADOFFSET
1051 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1052         int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1053 {
1054     dVAR;
1055     I32 offset, new_offset;
1056     SV *new_capture;
1057     SV **new_capturep;
1058     const AV * const padlist = CvPADLIST(cv);
1059
1060     PERL_ARGS_ASSERT_PAD_FINDLEX;
1061
1062     if (flags & ~padadd_UTF8_NAME)
1063         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1064                    (UV)flags);
1065
1066     *out_flags = 0;
1067
1068     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1069         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1070                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1071         out_capture ? " capturing" : "" ));
1072
1073     /* first, search this pad */
1074
1075     if (padlist) { /* not an undef CV */
1076         I32 fake_offset = 0;
1077         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1078         SV * const * const name_svp = AvARRAY(nameav);
1079
1080         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1081             const SV * const namesv = name_svp[offset];
1082             if (namesv && namesv != &PL_sv_undef
1083                     && SvCUR(namesv) == namelen
1084                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1085                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1086             {
1087                 if (SvFAKE(namesv)) {
1088                     fake_offset = offset; /* in case we don't find a real one */
1089                     continue;
1090                 }
1091                 /* is seq within the range _LOW to _HIGH ?
1092                  * This is complicated by the fact that PL_cop_seqmax
1093                  * may have wrapped around at some point */
1094                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1095                     continue; /* not yet introduced */
1096
1097                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1098                     /* in compiling scope */
1099                     if (
1100                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1101                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1102                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1103                     )
1104                        break;
1105                 }
1106                 else if (
1107                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1108                     ?
1109                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1110                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1111
1112                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1113                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1114                 )
1115                 break;
1116             }
1117         }
1118
1119         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1120             if (offset > 0) { /* not fake */
1121                 fake_offset = 0;
1122                 *out_name_sv = name_svp[offset]; /* return the namesv */
1123
1124                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1125                  * instances. For now, we just test !CvUNIQUE(cv), but
1126                  * ideally, we should detect my's declared within loops
1127                  * etc - this would allow a wider range of 'not stayed
1128                  * shared' warnings. We also treated already-compiled
1129                  * lexes as not multi as viewed from evals. */
1130
1131                 *out_flags = CvANON(cv) ?
1132                         PAD_FAKELEX_ANON :
1133                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1134                                 ? PAD_FAKELEX_MULTI : 0;
1135
1136                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1137                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1138                     PTR2UV(cv), (long)offset,
1139                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1140                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1141             }
1142             else { /* fake match */
1143                 offset = fake_offset;
1144                 *out_name_sv = name_svp[offset]; /* return the namesv */
1145                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1146                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1147                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1148                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1149                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1150                 ));
1151             }
1152
1153             /* return the lex? */
1154
1155             if (out_capture) {
1156
1157                 /* our ? */
1158                 if (SvPAD_OUR(*out_name_sv)) {
1159                     *out_capture = NULL;
1160                     return offset;
1161                 }
1162
1163                 /* trying to capture from an anon prototype? */
1164                 if (CvCOMPILED(cv)
1165                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1166                         : *out_flags & PAD_FAKELEX_ANON)
1167                 {
1168                     if (warn)
1169                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1170                                        "Variable \"%"SVf"\" is not available",
1171                                        newSVpvn_flags(namepv, namelen,
1172                                            SVs_TEMP |
1173                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1174
1175                     *out_capture = NULL;
1176                 }
1177
1178                 /* real value */
1179                 else {
1180                     int newwarn = warn;
1181                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1182                          && !SvPAD_STATE(name_svp[offset])
1183                          && warn && ckWARN(WARN_CLOSURE)) {
1184                         newwarn = 0;
1185                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1186                             "Variable \"%"SVf"\" will not stay shared",
1187                             newSVpvn_flags(namepv, namelen,
1188                                 SVs_TEMP |
1189                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1190                     }
1191
1192                     if (fake_offset && CvANON(cv)
1193                             && CvCLONE(cv) &&!CvCLONED(cv))
1194                     {
1195                         SV *n;
1196                         /* not yet caught - look further up */
1197                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1198                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1199                             PTR2UV(cv)));
1200                         n = *out_name_sv;
1201                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1202                             CvOUTSIDE_SEQ(cv),
1203                             newwarn, out_capture, out_name_sv, out_flags);
1204                         *out_name_sv = n;
1205                         return offset;
1206                     }
1207
1208                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1209                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1210                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1211                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1212                         PTR2UV(cv), PTR2UV(*out_capture)));
1213
1214                     if (SvPADSTALE(*out_capture)
1215                         && !SvPAD_STATE(name_svp[offset]))
1216                     {
1217                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1218                                        "Variable \"%"SVf"\" is not available",
1219                                        newSVpvn_flags(namepv, namelen,
1220                                            SVs_TEMP |
1221                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1222                         *out_capture = NULL;
1223                     }
1224                 }
1225                 if (!*out_capture) {
1226                     if (namelen != 0 && *namepv == '@')
1227                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1228                     else if (namelen != 0 && *namepv == '%')
1229                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1230                     else
1231                         *out_capture = sv_newmortal();
1232                 }
1233             }
1234
1235             return offset;
1236         }
1237     }
1238
1239     /* it's not in this pad - try above */
1240
1241     if (!CvOUTSIDE(cv))
1242         return NOT_IN_PAD;
1243
1244     /* out_capture non-null means caller wants us to capture lex; in
1245      * addition we capture ourselves unless it's an ANON/format */
1246     new_capturep = out_capture ? out_capture :
1247                 CvLATE(cv) ? NULL : &new_capture;
1248
1249     offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1250                 new_capturep, out_name_sv, out_flags);
1251     if ((PADOFFSET)offset == NOT_IN_PAD)
1252         return NOT_IN_PAD;
1253
1254     /* found in an outer CV. Add appropriate fake entry to this pad */
1255
1256     /* don't add new fake entries (via eval) to CVs that we have already
1257      * finished compiling, or to undef CVs */
1258     if (CvCOMPILED(cv) || !padlist)
1259         return 0; /* this dummy (and invalid) value isnt used by the caller */
1260
1261     {
1262         /* This relies on sv_setsv_flags() upgrading the destination to the same
1263            type as the source, independent of the flags set, and on it being
1264            "good" and only copying flag bits and pointers that it understands.
1265         */
1266         SV *new_namesv = newSVsv(*out_name_sv);
1267         AV *  const ocomppad_name = PL_comppad_name;
1268         PAD * const ocomppad = PL_comppad;
1269         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1270         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1271         PL_curpad = AvARRAY(PL_comppad);
1272
1273         new_offset
1274             = pad_alloc_name(new_namesv,
1275                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1276                               SvPAD_TYPED(*out_name_sv)
1277                               ? SvSTASH(*out_name_sv) : NULL,
1278                               SvOURSTASH(*out_name_sv)
1279                               );
1280
1281         SvFAKE_on(new_namesv);
1282         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1283                                "Pad addname: %ld \"%.*s\" FAKE\n",
1284                                (long)new_offset,
1285                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1286         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1287
1288         PARENT_PAD_INDEX_set(new_namesv, 0);
1289         if (SvPAD_OUR(new_namesv)) {
1290             NOOP;   /* do nothing */
1291         }
1292         else if (CvLATE(cv)) {
1293             /* delayed creation - just note the offset within parent pad */
1294             PARENT_PAD_INDEX_set(new_namesv, offset);
1295             CvCLONE_on(cv);
1296         }
1297         else {
1298             /* immediate creation - capture outer value right now */
1299             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1300             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1301                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1302                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1303         }
1304         *out_name_sv = new_namesv;
1305         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1306
1307         PL_comppad_name = ocomppad_name;
1308         PL_comppad = ocomppad;
1309         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1310     }
1311     return new_offset;
1312 }
1313
1314 #ifdef DEBUGGING
1315
1316 /*
1317 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1318
1319 Get the value at offset I<po> in the current (compiling or executing) pad.
1320 Use macro PAD_SV instead of calling this function directly.
1321
1322 =cut
1323 */
1324
1325 SV *
1326 Perl_pad_sv(pTHX_ PADOFFSET po)
1327 {
1328     dVAR;
1329     ASSERT_CURPAD_ACTIVE("pad_sv");
1330
1331     if (!po)
1332         Perl_croak(aTHX_ "panic: pad_sv po");
1333     DEBUG_X(PerlIO_printf(Perl_debug_log,
1334         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1335         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1336     );
1337     return PL_curpad[po];
1338 }
1339
1340 /*
1341 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1342
1343 Set the value at offset I<po> in the current (compiling or executing) pad.
1344 Use the macro PAD_SETSV() rather than calling this function directly.
1345
1346 =cut
1347 */
1348
1349 void
1350 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1351 {
1352     dVAR;
1353
1354     PERL_ARGS_ASSERT_PAD_SETSV;
1355
1356     ASSERT_CURPAD_ACTIVE("pad_setsv");
1357
1358     DEBUG_X(PerlIO_printf(Perl_debug_log,
1359         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1360         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1361     );
1362     PL_curpad[po] = sv;
1363 }
1364
1365 #endif /* DEBUGGING */
1366
1367 /*
1368 =for apidoc m|void|pad_block_start|int full
1369
1370 Update the pad compilation state variables on entry to a new block
1371
1372 =cut
1373 */
1374
1375 /* XXX DAPM perhaps:
1376  *      - integrate this in general state-saving routine ???
1377  *      - combine with the state-saving going on in pad_new ???
1378  *      - introduce a new SAVE type that does all this in one go ?
1379  */
1380
1381 void
1382 Perl_pad_block_start(pTHX_ int full)
1383 {
1384     dVAR;
1385     ASSERT_CURPAD_ACTIVE("pad_block_start");
1386     SAVEI32(PL_comppad_name_floor);
1387     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1388     if (full)
1389         PL_comppad_name_fill = PL_comppad_name_floor;
1390     if (PL_comppad_name_floor < 0)
1391         PL_comppad_name_floor = 0;
1392     SAVEI32(PL_min_intro_pending);
1393     SAVEI32(PL_max_intro_pending);
1394     PL_min_intro_pending = 0;
1395     SAVEI32(PL_comppad_name_fill);
1396     SAVEI32(PL_padix_floor);
1397     PL_padix_floor = PL_padix;
1398     PL_pad_reset_pending = FALSE;
1399 }
1400
1401 /*
1402 =for apidoc m|U32|intro_my
1403
1404 "Introduce" my variables to visible status.
1405
1406 =cut
1407 */
1408
1409 U32
1410 Perl_intro_my(pTHX)
1411 {
1412     dVAR;
1413     SV **svp;
1414     I32 i;
1415     U32 seq;
1416
1417     ASSERT_CURPAD_ACTIVE("intro_my");
1418     if (! PL_min_intro_pending)
1419         return PL_cop_seqmax;
1420
1421     svp = AvARRAY(PL_comppad_name);
1422     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1423         SV * const sv = svp[i];
1424
1425         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1426             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1427         {
1428             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1429             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1430             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1431                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1432                 (long)i, SvPVX_const(sv),
1433                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1434                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1435             );
1436         }
1437     }
1438     seq = PL_cop_seqmax;
1439     PL_cop_seqmax++;
1440     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1441         PL_cop_seqmax++;
1442     PL_min_intro_pending = 0;
1443     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1444     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1445                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1446
1447     return seq;
1448 }
1449
1450 /*
1451 =for apidoc m|void|pad_leavemy
1452
1453 Cleanup at end of scope during compilation: set the max seq number for
1454 lexicals in this scope and warn of any lexicals that never got introduced.
1455
1456 =cut
1457 */
1458
1459 void
1460 Perl_pad_leavemy(pTHX)
1461 {
1462     dVAR;
1463     I32 off;
1464     SV * const * const svp = AvARRAY(PL_comppad_name);
1465
1466     PL_pad_reset_pending = FALSE;
1467
1468     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1469     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1470         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1471             const SV * const sv = svp[off];
1472             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1473                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1474                                  "%"SVf" never introduced",
1475                                  SVfARG(sv));
1476         }
1477     }
1478     /* "Deintroduce" my variables that are leaving with this scope. */
1479     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1480         const SV * const sv = svp[off];
1481         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1482             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1483         {
1484             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1485             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1486                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1487                 (long)off, SvPVX_const(sv),
1488                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1489                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1490             );
1491         }
1492     }
1493     PL_cop_seqmax++;
1494     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1495         PL_cop_seqmax++;
1496     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1497             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1498 }
1499
1500 /*
1501 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1502
1503 Abandon the tmp in the current pad at offset po and replace with a
1504 new one.
1505
1506 =cut
1507 */
1508
1509 void
1510 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1511 {
1512     dVAR;
1513     ASSERT_CURPAD_LEGAL("pad_swipe");
1514     if (!PL_curpad)
1515         return;
1516     if (AvARRAY(PL_comppad) != PL_curpad)
1517         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1518                    AvARRAY(PL_comppad), PL_curpad);
1519     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1520         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1521                    (long)po, (long)AvFILLp(PL_comppad));
1522
1523     DEBUG_X(PerlIO_printf(Perl_debug_log,
1524                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1525                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1526
1527     if (PL_curpad[po])
1528         SvPADTMP_off(PL_curpad[po]);
1529     if (refadjust)
1530         SvREFCNT_dec(PL_curpad[po]);
1531
1532
1533     /* if pad tmps aren't shared between ops, then there's no need to
1534      * create a new tmp when an existing op is freed */
1535 #ifdef USE_BROKEN_PAD_RESET
1536     PL_curpad[po] = newSV(0);
1537     SvPADTMP_on(PL_curpad[po]);
1538 #else
1539     PL_curpad[po] = &PL_sv_undef;
1540 #endif
1541     if ((I32)po < PL_padix)
1542         PL_padix = po - 1;
1543 }
1544
1545 /*
1546 =for apidoc m|void|pad_reset
1547
1548 Mark all the current temporaries for reuse
1549
1550 =cut
1551 */
1552
1553 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1554  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1555  * on the stack by OPs that use them, there are several ways to get an alias
1556  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1557  * We avoid doing this until we can think of a Better Way.
1558  * GSAR 97-10-29 */
1559 static void
1560 S_pad_reset(pTHX)
1561 {
1562     dVAR;
1563 #ifdef USE_BROKEN_PAD_RESET
1564     if (AvARRAY(PL_comppad) != PL_curpad)
1565         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1566                    AvARRAY(PL_comppad), PL_curpad);
1567
1568     DEBUG_X(PerlIO_printf(Perl_debug_log,
1569             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1570             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1571                 (long)PL_padix, (long)PL_padix_floor
1572             )
1573     );
1574
1575     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1576         register I32 po;
1577         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1578             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1579                 SvPADTMP_off(PL_curpad[po]);
1580         }
1581         PL_padix = PL_padix_floor;
1582     }
1583 #endif
1584     PL_pad_reset_pending = FALSE;
1585 }
1586
1587 /*
1588 =for apidoc Amx|void|pad_tidy|padtidy_type type
1589
1590 Tidy up a pad at the end of compilation of the code to which it belongs.
1591 Jobs performed here are: remove most stuff from the pads of anonsub
1592 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1593 the kind of subroutine:
1594
1595     padtidy_SUB        ordinary subroutine
1596     padtidy_SUBCLONE   prototype for lexical closure
1597     padtidy_FORMAT     format
1598
1599 =cut
1600 */
1601
1602 /* XXX DAPM surely most of this stuff should be done properly
1603  * at the right time beforehand, rather than going around afterwards
1604  * cleaning up our mistakes ???
1605  */
1606
1607 void
1608 Perl_pad_tidy(pTHX_ padtidy_type type)
1609 {
1610     dVAR;
1611
1612     ASSERT_CURPAD_ACTIVE("pad_tidy");
1613
1614     /* If this CV has had any 'eval-capable' ops planted in it
1615      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1616      * anon prototypes in the chain of CVs should be marked as cloneable,
1617      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1618      * the right CvOUTSIDE.
1619      * If running with -d, *any* sub may potentially have an eval
1620      * executed within it.
1621      */
1622
1623     if (PL_cv_has_eval || PL_perldb) {
1624         const CV *cv;
1625         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1626             if (cv != PL_compcv && CvCOMPILED(cv))
1627                 break; /* no need to mark already-compiled code */
1628             if (CvANON(cv)) {
1629                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1630                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1631                 CvCLONE_on(cv);
1632             }
1633         }
1634     }
1635
1636     /* extend curpad to match namepad */
1637     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1638         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1639
1640     if (type == padtidy_SUBCLONE) {
1641         SV * const * const namep = AvARRAY(PL_comppad_name);
1642         PADOFFSET ix;
1643
1644         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1645             SV *namesv;
1646
1647             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1648                 continue;
1649             /*
1650              * The only things that a clonable function needs in its
1651              * pad are anonymous subs.
1652              * The rest are created anew during cloning.
1653              */
1654             if (!((namesv = namep[ix]) != NULL &&
1655                   namesv != &PL_sv_undef &&
1656                    *SvPVX_const(namesv) == '&'))
1657             {
1658                 SvREFCNT_dec(PL_curpad[ix]);
1659                 PL_curpad[ix] = NULL;
1660             }
1661         }
1662     }
1663     else if (type == padtidy_SUB) {
1664         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1665         AV * const av = newAV();                        /* Will be @_ */
1666         av_store(PL_comppad, 0, MUTABLE_SV(av));
1667         AvREIFY_only(av);
1668     }
1669
1670     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1671         SV * const * const namep = AvARRAY(PL_comppad_name);
1672         PADOFFSET ix;
1673         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1674             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1675                 continue;
1676             if (!SvPADMY(PL_curpad[ix])) {
1677                 SvPADTMP_on(PL_curpad[ix]);
1678             } else if (!SvFAKE(namep[ix])) {
1679                 /* This is a work around for how the current implementation of
1680                    ?{ } blocks in regexps interacts with lexicals.
1681
1682                    One of our lexicals.
1683                    Can't do this on all lexicals, otherwise sub baz() won't
1684                    compile in
1685
1686                    my $foo;
1687
1688                    sub bar { ++$foo; }
1689
1690                    sub baz { ++$foo; }
1691
1692                    because completion of compiling &bar calling pad_tidy()
1693                    would cause (top level) $foo to be marked as stale, and
1694                    "no longer available".  */
1695                 SvPADSTALE_on(PL_curpad[ix]);
1696             }
1697         }
1698     }
1699     PL_curpad = AvARRAY(PL_comppad);
1700 }
1701
1702 /*
1703 =for apidoc m|void|pad_free|PADOFFSET po
1704
1705 Free the SV at offset po in the current pad.
1706
1707 =cut
1708 */
1709
1710 /* XXX DAPM integrate with pad_swipe ???? */
1711 void
1712 Perl_pad_free(pTHX_ PADOFFSET po)
1713 {
1714     dVAR;
1715     ASSERT_CURPAD_LEGAL("pad_free");
1716     if (!PL_curpad)
1717         return;
1718     if (AvARRAY(PL_comppad) != PL_curpad)
1719         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1720                    AvARRAY(PL_comppad), PL_curpad);
1721     if (!po)
1722         Perl_croak(aTHX_ "panic: pad_free po");
1723
1724     DEBUG_X(PerlIO_printf(Perl_debug_log,
1725             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1726             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1727     );
1728
1729     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1730         SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1731     }
1732     if ((I32)po < PL_padix)
1733         PL_padix = po - 1;
1734 }
1735
1736 /*
1737 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1738
1739 Dump the contents of a padlist
1740
1741 =cut
1742 */
1743
1744 void
1745 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1746 {
1747     dVAR;
1748     const AV *pad_name;
1749     const AV *pad;
1750     SV **pname;
1751     SV **ppad;
1752     I32 ix;
1753
1754     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1755
1756     if (!padlist) {
1757         return;
1758     }
1759     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1760     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1761     pname = AvARRAY(pad_name);
1762     ppad = AvARRAY(pad);
1763     Perl_dump_indent(aTHX_ level, file,
1764             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1765             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1766     );
1767
1768     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1769         const SV *namesv = pname[ix];
1770         if (namesv && namesv == &PL_sv_undef) {
1771             namesv = NULL;
1772         }
1773         if (namesv) {
1774             if (SvFAKE(namesv))
1775                 Perl_dump_indent(aTHX_ level+1, file,
1776                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1777                     (int) ix,
1778                     PTR2UV(ppad[ix]),
1779                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1780                     SvPVX_const(namesv),
1781                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1782                     (unsigned long)PARENT_PAD_INDEX(namesv)
1783
1784                 );
1785             else
1786                 Perl_dump_indent(aTHX_ level+1, file,
1787                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1788                     (int) ix,
1789                     PTR2UV(ppad[ix]),
1790                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1791                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1792                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1793                     SvPVX_const(namesv)
1794                 );
1795         }
1796         else if (full) {
1797             Perl_dump_indent(aTHX_ level+1, file,
1798                 "%2d. 0x%"UVxf"<%lu>\n",
1799                 (int) ix,
1800                 PTR2UV(ppad[ix]),
1801                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1802             );
1803         }
1804     }
1805 }
1806
1807 #ifdef DEBUGGING
1808
1809 /*
1810 =for apidoc m|void|cv_dump|CV *cv|const char *title
1811
1812 dump the contents of a CV
1813
1814 =cut
1815 */
1816
1817 STATIC void
1818 S_cv_dump(pTHX_ const CV *cv, const char *title)
1819 {
1820     dVAR;
1821     const CV * const outside = CvOUTSIDE(cv);
1822     AV* const padlist = CvPADLIST(cv);
1823
1824     PERL_ARGS_ASSERT_CV_DUMP;
1825
1826     PerlIO_printf(Perl_debug_log,
1827                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1828                   title,
1829                   PTR2UV(cv),
1830                   (CvANON(cv) ? "ANON"
1831                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1832                    : (cv == PL_main_cv) ? "MAIN"
1833                    : CvUNIQUE(cv) ? "UNIQUE"
1834                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1835                   PTR2UV(outside),
1836                   (!outside ? "null"
1837                    : CvANON(outside) ? "ANON"
1838                    : (outside == PL_main_cv) ? "MAIN"
1839                    : CvUNIQUE(outside) ? "UNIQUE"
1840                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1841
1842     PerlIO_printf(Perl_debug_log,
1843                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1844     do_dump_pad(1, Perl_debug_log, padlist, 1);
1845 }
1846
1847 #endif /* DEBUGGING */
1848
1849 /*
1850 =for apidoc Am|CV *|cv_clone|CV *proto
1851
1852 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1853 of the function: its code, pad structure, and other attributes.
1854 The prototype is combined with a capture of outer lexicals to which the
1855 code refers, which are taken from the currently-executing instance of
1856 the immediately surrounding code.
1857
1858 =cut
1859 */
1860
1861 CV *
1862 Perl_cv_clone(pTHX_ CV *proto)
1863 {
1864     dVAR;
1865     I32 ix;
1866     AV* const protopadlist = CvPADLIST(proto);
1867     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1868     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1869     SV** const pname = AvARRAY(protopad_name);
1870     SV** const ppad = AvARRAY(protopad);
1871     const I32 fname = AvFILLp(protopad_name);
1872     const I32 fpad = AvFILLp(protopad);
1873     CV* cv;
1874     SV** outpad;
1875     CV* outside;
1876     long depth;
1877
1878     PERL_ARGS_ASSERT_CV_CLONE;
1879
1880     assert(!CvUNIQUE(proto));
1881
1882     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1883      * to a prototype; we instead want the cloned parent who called us.
1884      * Note that in general for formats, CvOUTSIDE != find_runcv */
1885
1886     outside = CvOUTSIDE(proto);
1887     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1888         outside = find_runcv(NULL);
1889     depth = CvDEPTH(outside);
1890     assert(depth || SvTYPE(proto) == SVt_PVFM);
1891     if (!depth)
1892         depth = 1;
1893     assert(CvPADLIST(outside));
1894
1895     ENTER;
1896     SAVESPTR(PL_compcv);
1897
1898     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1899     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1900     CvCLONED_on(cv);
1901
1902     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1903                                            : CvFILE(proto);
1904     CvGV_set(cv,CvGV(proto));
1905     CvSTASH_set(cv, CvSTASH(proto));
1906     OP_REFCNT_LOCK;
1907     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1908     OP_REFCNT_UNLOCK;
1909     CvSTART(cv)         = CvSTART(proto);
1910     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1911     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1912
1913     if (SvPOK(proto))
1914         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1915     if (SvMAGIC(proto))
1916         mg_copy((SV *)proto, (SV *)cv, 0, 0);
1917
1918     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1919
1920     av_fill(PL_comppad, fpad);
1921     for (ix = fname; ix > 0; ix--)
1922         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1923
1924     PL_curpad = AvARRAY(PL_comppad);
1925
1926     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1927
1928     for (ix = fpad; ix > 0; ix--) {
1929         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1930         SV *sv = NULL;
1931         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1932             if (SvFAKE(namesv)) {   /* lexical from outside? */
1933                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1934                 assert(sv);
1935                 /* formats may have an inactive parent,
1936                    while my $x if $false can leave an active var marked as
1937                    stale. And state vars are always available */
1938                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1939                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1940                                    "Variable \"%"SVf"\" is not available", namesv);
1941                     sv = NULL;
1942                 }
1943                 else 
1944                     SvREFCNT_inc_simple_void_NN(sv);
1945             }
1946             if (!sv) {
1947                 const char sigil = SvPVX_const(namesv)[0];
1948                 if (sigil == '&')
1949                     sv = SvREFCNT_inc(ppad[ix]);
1950                 else if (sigil == '@')
1951                     sv = MUTABLE_SV(newAV());
1952                 else if (sigil == '%')
1953                     sv = MUTABLE_SV(newHV());
1954                 else
1955                     sv = newSV(0);
1956                 SvPADMY_on(sv);
1957                 /* reset the 'assign only once' flag on each state var */
1958                 if (SvPAD_STATE(namesv))
1959                     SvPADSTALE_on(sv);
1960             }
1961         }
1962         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1963             sv = SvREFCNT_inc_NN(ppad[ix]);
1964         }
1965         else {
1966             sv = newSV(0);
1967             SvPADTMP_on(sv);
1968         }
1969         PL_curpad[ix] = sv;
1970     }
1971
1972     DEBUG_Xv(
1973         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1974         cv_dump(outside, "Outside");
1975         cv_dump(proto,   "Proto");
1976         cv_dump(cv,      "To");
1977     );
1978
1979     LEAVE;
1980
1981     if (CvCONST(cv)) {
1982         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1983          * The prototype was marked as a candiate for const-ization,
1984          * so try to grab the current const value, and if successful,
1985          * turn into a const sub:
1986          */
1987         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1988         if (const_sv) {
1989             SvREFCNT_dec(cv);
1990             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1991         }
1992         else {
1993             CvCONST_off(cv);
1994         }
1995     }
1996
1997     return cv;
1998 }
1999
2000 /*
2001 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2002
2003 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2004 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2005 moved to a pre-existing CV struct.
2006
2007 =cut
2008 */
2009
2010 void
2011 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2012 {
2013     dVAR;
2014     I32 ix;
2015     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2016     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2017     SV ** const namepad = AvARRAY(comppad_name);
2018     SV ** const curpad = AvARRAY(comppad);
2019
2020     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2021     PERL_UNUSED_ARG(old_cv);
2022
2023     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2024         const SV * const namesv = namepad[ix];
2025         if (namesv && namesv != &PL_sv_undef
2026             && *SvPVX_const(namesv) == '&')
2027         {
2028             CV * const innercv = MUTABLE_CV(curpad[ix]);
2029             assert(CvWEAKOUTSIDE(innercv));
2030             assert(CvOUTSIDE(innercv) == old_cv);
2031             CvOUTSIDE(innercv) = new_cv;
2032         }
2033     }
2034 }
2035
2036 /*
2037 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2038
2039 Push a new pad frame onto the padlist, unless there's already a pad at
2040 this depth, in which case don't bother creating a new one.  Then give
2041 the new pad an @_ in slot zero.
2042
2043 =cut
2044 */
2045
2046 void
2047 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2048 {
2049     dVAR;
2050
2051     PERL_ARGS_ASSERT_PAD_PUSH;
2052
2053     if (depth > AvFILLp(padlist)) {
2054         SV** const svp = AvARRAY(padlist);
2055         AV* const newpad = newAV();
2056         SV** const oldpad = AvARRAY(svp[depth-1]);
2057         I32 ix = AvFILLp((const AV *)svp[1]);
2058         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2059         SV** const names = AvARRAY(svp[0]);
2060         AV *av;
2061
2062         for ( ;ix > 0; ix--) {
2063             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2064                 const char sigil = SvPVX_const(names[ix])[0];
2065                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2066                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2067                         || sigil == '&')
2068                 {
2069                     /* outer lexical or anon code */
2070                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2071                 }
2072                 else {          /* our own lexical */
2073                     SV *sv; 
2074                     if (sigil == '@')
2075                         sv = MUTABLE_SV(newAV());
2076                     else if (sigil == '%')
2077                         sv = MUTABLE_SV(newHV());
2078                     else
2079                         sv = newSV(0);
2080                     av_store(newpad, ix, sv);
2081                     SvPADMY_on(sv);
2082                 }
2083             }
2084             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2085                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2086             }
2087             else {
2088                 /* save temporaries on recursion? */
2089                 SV * const sv = newSV(0);
2090                 av_store(newpad, ix, sv);
2091                 SvPADTMP_on(sv);
2092             }
2093         }
2094         av = newAV();
2095         av_store(newpad, 0, MUTABLE_SV(av));
2096         AvREIFY_only(av);
2097
2098         av_store(padlist, depth, MUTABLE_SV(newpad));
2099         AvFILLp(padlist) = depth;
2100     }
2101 }
2102
2103 /*
2104 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2105
2106 Looks up the type of the lexical variable at position I<po> in the
2107 currently-compiling pad.  If the variable is typed, the stash of the
2108 class to which it is typed is returned.  If not, C<NULL> is returned.
2109
2110 =cut
2111 */
2112
2113 HV *
2114 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2115 {
2116     dVAR;
2117     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2118     if ( SvPAD_TYPED(*av) ) {
2119         return SvSTASH(*av);
2120     }
2121     return NULL;
2122 }
2123
2124 #if defined(USE_ITHREADS)
2125
2126 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2127
2128 /*
2129 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2130
2131 Duplicates a pad.
2132
2133 =cut
2134 */
2135
2136 AV *
2137 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2138 {
2139     AV *dstpad;
2140     PERL_ARGS_ASSERT_PADLIST_DUP;
2141
2142     if (!srcpad)
2143         return NULL;
2144
2145     if (param->flags & CLONEf_COPY_STACKS
2146         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2147         dstpad = av_dup_inc(srcpad, param);
2148         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2149     } else {
2150         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2151            to build anything other than the first level of pads.  */
2152
2153         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2154         AV *pad1;
2155         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2156         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2157         SV **oldpad = AvARRAY(srcpad1);
2158         SV **names;
2159         SV **pad1a;
2160         AV *args;
2161         /* Look for it in the table first, as the padlist may have ended up
2162            as an element of @DB::args (or theoretically even @_), so it may
2163            may have been cloned already.  It may also be there because of
2164            how Perl_sv_compile_2op() "works". :-(   */
2165         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2166
2167         if (dstpad)
2168             return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2169
2170         dstpad = newAV();
2171         ptr_table_store(PL_ptr_table, srcpad, dstpad);
2172         av_extend(dstpad, 1);
2173         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2174         names = AvARRAY(AvARRAY(dstpad)[0]);
2175
2176         pad1 = newAV();
2177
2178         av_extend(pad1, ix);
2179         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2180         pad1a = AvARRAY(pad1);
2181         AvFILLp(dstpad) = 1;
2182
2183         if (ix > -1) {
2184             AvFILLp(pad1) = ix;
2185
2186             for ( ;ix > 0; ix--) {
2187                 if (!oldpad[ix]) {
2188                     pad1a[ix] = NULL;
2189                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2190                     const char sigil = SvPVX_const(names[ix])[0];
2191                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2192                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2193                         || sigil == '&')
2194                         {
2195                             /* outer lexical or anon code */
2196                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2197                         }
2198                     else {              /* our own lexical */
2199                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2200                             /* This is a work around for how the current
2201                                implementation of ?{ } blocks in regexps
2202                                interacts with lexicals.  */
2203                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2204                         } else {
2205                             SV *sv; 
2206                             
2207                             if (sigil == '@')
2208                                 sv = MUTABLE_SV(newAV());
2209                             else if (sigil == '%')
2210                                 sv = MUTABLE_SV(newHV());
2211                             else
2212                                 sv = newSV(0);
2213                             pad1a[ix] = sv;
2214                             SvPADMY_on(sv);
2215                         }
2216                     }
2217                 }
2218                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2219                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2220                 }
2221                 else {
2222                     /* save temporaries on recursion? */
2223                     SV * const sv = newSV(0);
2224                     pad1a[ix] = sv;
2225
2226                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2227                        FIXTHAT before merging this branch.
2228                        (And I know how to) */
2229                     if (SvPADMY(oldpad[ix]))
2230                         SvPADMY_on(sv);
2231                     else
2232                         SvPADTMP_on(sv);
2233                 }
2234             }
2235
2236             if (oldpad[0]) {
2237                 args = newAV();                 /* Will be @_ */
2238                 AvREIFY_only(args);
2239                 pad1a[0] = (SV *)args;
2240             }
2241         }
2242     }
2243
2244     return dstpad;
2245 }
2246
2247 #endif /* USE_ITHREADS */
2248
2249 /*
2250  * Local variables:
2251  * c-indentation-style: bsd
2252  * c-basic-offset: 4
2253  * indent-tabs-mode: t
2254  * End:
2255  *
2256  * ex: set ts=8 sts=4 sw=4 noet:
2257  */