correctly clone eval context frames
[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)
1520         Perl_croak(aTHX_ "panic: pad_swipe po");
1521
1522     DEBUG_X(PerlIO_printf(Perl_debug_log,
1523                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1524                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1525
1526     if (PL_curpad[po])
1527         SvPADTMP_off(PL_curpad[po]);
1528     if (refadjust)
1529         SvREFCNT_dec(PL_curpad[po]);
1530
1531
1532     /* if pad tmps aren't shared between ops, then there's no need to
1533      * create a new tmp when an existing op is freed */
1534 #ifdef USE_BROKEN_PAD_RESET
1535     PL_curpad[po] = newSV(0);
1536     SvPADTMP_on(PL_curpad[po]);
1537 #else
1538     PL_curpad[po] = &PL_sv_undef;
1539 #endif
1540     if ((I32)po < PL_padix)
1541         PL_padix = po - 1;
1542 }
1543
1544 /*
1545 =for apidoc m|void|pad_reset
1546
1547 Mark all the current temporaries for reuse
1548
1549 =cut
1550 */
1551
1552 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1553  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1554  * on the stack by OPs that use them, there are several ways to get an alias
1555  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1556  * We avoid doing this until we can think of a Better Way.
1557  * GSAR 97-10-29 */
1558 static void
1559 S_pad_reset(pTHX)
1560 {
1561     dVAR;
1562 #ifdef USE_BROKEN_PAD_RESET
1563     if (AvARRAY(PL_comppad) != PL_curpad)
1564         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1565                    AvARRAY(PL_comppad), PL_curpad);
1566
1567     DEBUG_X(PerlIO_printf(Perl_debug_log,
1568             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1569             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1570                 (long)PL_padix, (long)PL_padix_floor
1571             )
1572     );
1573
1574     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1575         register I32 po;
1576         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1577             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1578                 SvPADTMP_off(PL_curpad[po]);
1579         }
1580         PL_padix = PL_padix_floor;
1581     }
1582 #endif
1583     PL_pad_reset_pending = FALSE;
1584 }
1585
1586 /*
1587 =for apidoc Amx|void|pad_tidy|padtidy_type type
1588
1589 Tidy up a pad at the end of compilation of the code to which it belongs.
1590 Jobs performed here are: remove most stuff from the pads of anonsub
1591 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1592 the kind of subroutine:
1593
1594     padtidy_SUB        ordinary subroutine
1595     padtidy_SUBCLONE   prototype for lexical closure
1596     padtidy_FORMAT     format
1597
1598 =cut
1599 */
1600
1601 /* XXX DAPM surely most of this stuff should be done properly
1602  * at the right time beforehand, rather than going around afterwards
1603  * cleaning up our mistakes ???
1604  */
1605
1606 void
1607 Perl_pad_tidy(pTHX_ padtidy_type type)
1608 {
1609     dVAR;
1610
1611     ASSERT_CURPAD_ACTIVE("pad_tidy");
1612
1613     /* If this CV has had any 'eval-capable' ops planted in it
1614      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1615      * anon prototypes in the chain of CVs should be marked as cloneable,
1616      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1617      * the right CvOUTSIDE.
1618      * If running with -d, *any* sub may potentially have an eval
1619      * executed within it.
1620      */
1621
1622     if (PL_cv_has_eval || PL_perldb) {
1623         const CV *cv;
1624         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1625             if (cv != PL_compcv && CvCOMPILED(cv))
1626                 break; /* no need to mark already-compiled code */
1627             if (CvANON(cv)) {
1628                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1629                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1630                 CvCLONE_on(cv);
1631             }
1632         }
1633     }
1634
1635     /* extend curpad to match namepad */
1636     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1637         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1638
1639     if (type == padtidy_SUBCLONE) {
1640         SV * const * const namep = AvARRAY(PL_comppad_name);
1641         PADOFFSET ix;
1642
1643         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1644             SV *namesv;
1645
1646             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1647                 continue;
1648             /*
1649              * The only things that a clonable function needs in its
1650              * pad are anonymous subs.
1651              * The rest are created anew during cloning.
1652              */
1653             if (!((namesv = namep[ix]) != NULL &&
1654                   namesv != &PL_sv_undef &&
1655                    *SvPVX_const(namesv) == '&'))
1656             {
1657                 SvREFCNT_dec(PL_curpad[ix]);
1658                 PL_curpad[ix] = NULL;
1659             }
1660         }
1661     }
1662     else if (type == padtidy_SUB) {
1663         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1664         AV * const av = newAV();                        /* Will be @_ */
1665         av_store(PL_comppad, 0, MUTABLE_SV(av));
1666         AvREIFY_only(av);
1667     }
1668
1669     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1670         SV * const * const namep = AvARRAY(PL_comppad_name);
1671         PADOFFSET ix;
1672         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1673             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1674                 continue;
1675             if (!SvPADMY(PL_curpad[ix])) {
1676                 SvPADTMP_on(PL_curpad[ix]);
1677             } else if (!SvFAKE(namep[ix])) {
1678                 /* This is a work around for how the current implementation of
1679                    ?{ } blocks in regexps interacts with lexicals.
1680
1681                    One of our lexicals.
1682                    Can't do this on all lexicals, otherwise sub baz() won't
1683                    compile in
1684
1685                    my $foo;
1686
1687                    sub bar { ++$foo; }
1688
1689                    sub baz { ++$foo; }
1690
1691                    because completion of compiling &bar calling pad_tidy()
1692                    would cause (top level) $foo to be marked as stale, and
1693                    "no longer available".  */
1694                 SvPADSTALE_on(PL_curpad[ix]);
1695             }
1696         }
1697     }
1698     PL_curpad = AvARRAY(PL_comppad);
1699 }
1700
1701 /*
1702 =for apidoc m|void|pad_free|PADOFFSET po
1703
1704 Free the SV at offset po in the current pad.
1705
1706 =cut
1707 */
1708
1709 /* XXX DAPM integrate with pad_swipe ???? */
1710 void
1711 Perl_pad_free(pTHX_ PADOFFSET po)
1712 {
1713     dVAR;
1714     ASSERT_CURPAD_LEGAL("pad_free");
1715     if (!PL_curpad)
1716         return;
1717     if (AvARRAY(PL_comppad) != PL_curpad)
1718         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1719                    AvARRAY(PL_comppad), PL_curpad);
1720     if (!po)
1721         Perl_croak(aTHX_ "panic: pad_free po");
1722
1723     DEBUG_X(PerlIO_printf(Perl_debug_log,
1724             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1725             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1726     );
1727
1728     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1729         SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1730     }
1731     if ((I32)po < PL_padix)
1732         PL_padix = po - 1;
1733 }
1734
1735 /*
1736 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1737
1738 Dump the contents of a padlist
1739
1740 =cut
1741 */
1742
1743 void
1744 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1745 {
1746     dVAR;
1747     const AV *pad_name;
1748     const AV *pad;
1749     SV **pname;
1750     SV **ppad;
1751     I32 ix;
1752
1753     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1754
1755     if (!padlist) {
1756         return;
1757     }
1758     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1759     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1760     pname = AvARRAY(pad_name);
1761     ppad = AvARRAY(pad);
1762     Perl_dump_indent(aTHX_ level, file,
1763             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1764             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1765     );
1766
1767     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1768         const SV *namesv = pname[ix];
1769         if (namesv && namesv == &PL_sv_undef) {
1770             namesv = NULL;
1771         }
1772         if (namesv) {
1773             if (SvFAKE(namesv))
1774                 Perl_dump_indent(aTHX_ level+1, file,
1775                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1776                     (int) ix,
1777                     PTR2UV(ppad[ix]),
1778                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1779                     SvPVX_const(namesv),
1780                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1781                     (unsigned long)PARENT_PAD_INDEX(namesv)
1782
1783                 );
1784             else
1785                 Perl_dump_indent(aTHX_ level+1, file,
1786                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1787                     (int) ix,
1788                     PTR2UV(ppad[ix]),
1789                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1790                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1791                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1792                     SvPVX_const(namesv)
1793                 );
1794         }
1795         else if (full) {
1796             Perl_dump_indent(aTHX_ level+1, file,
1797                 "%2d. 0x%"UVxf"<%lu>\n",
1798                 (int) ix,
1799                 PTR2UV(ppad[ix]),
1800                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1801             );
1802         }
1803     }
1804 }
1805
1806 #ifdef DEBUGGING
1807
1808 /*
1809 =for apidoc m|void|cv_dump|CV *cv|const char *title
1810
1811 dump the contents of a CV
1812
1813 =cut
1814 */
1815
1816 STATIC void
1817 S_cv_dump(pTHX_ const CV *cv, const char *title)
1818 {
1819     dVAR;
1820     const CV * const outside = CvOUTSIDE(cv);
1821     AV* const padlist = CvPADLIST(cv);
1822
1823     PERL_ARGS_ASSERT_CV_DUMP;
1824
1825     PerlIO_printf(Perl_debug_log,
1826                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1827                   title,
1828                   PTR2UV(cv),
1829                   (CvANON(cv) ? "ANON"
1830                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1831                    : (cv == PL_main_cv) ? "MAIN"
1832                    : CvUNIQUE(cv) ? "UNIQUE"
1833                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1834                   PTR2UV(outside),
1835                   (!outside ? "null"
1836                    : CvANON(outside) ? "ANON"
1837                    : (outside == PL_main_cv) ? "MAIN"
1838                    : CvUNIQUE(outside) ? "UNIQUE"
1839                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1840
1841     PerlIO_printf(Perl_debug_log,
1842                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1843     do_dump_pad(1, Perl_debug_log, padlist, 1);
1844 }
1845
1846 #endif /* DEBUGGING */
1847
1848 /*
1849 =for apidoc Am|CV *|cv_clone|CV *proto
1850
1851 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1852 of the function: its code, pad structure, and other attributes.
1853 The prototype is combined with a capture of outer lexicals to which the
1854 code refers, which are taken from the currently-executing instance of
1855 the immediately surrounding code.
1856
1857 =cut
1858 */
1859
1860 CV *
1861 Perl_cv_clone(pTHX_ CV *proto)
1862 {
1863     dVAR;
1864     I32 ix;
1865     AV* const protopadlist = CvPADLIST(proto);
1866     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1867     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1868     SV** const pname = AvARRAY(protopad_name);
1869     SV** const ppad = AvARRAY(protopad);
1870     const I32 fname = AvFILLp(protopad_name);
1871     const I32 fpad = AvFILLp(protopad);
1872     CV* cv;
1873     SV** outpad;
1874     CV* outside;
1875     long depth;
1876
1877     PERL_ARGS_ASSERT_CV_CLONE;
1878
1879     assert(!CvUNIQUE(proto));
1880
1881     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1882      * to a prototype; we instead want the cloned parent who called us.
1883      * Note that in general for formats, CvOUTSIDE != find_runcv */
1884
1885     outside = CvOUTSIDE(proto);
1886     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1887         outside = find_runcv(NULL);
1888     depth = CvDEPTH(outside);
1889     assert(depth || SvTYPE(proto) == SVt_PVFM);
1890     if (!depth)
1891         depth = 1;
1892     assert(CvPADLIST(outside));
1893
1894     ENTER;
1895     SAVESPTR(PL_compcv);
1896
1897     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1898     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1899     CvCLONED_on(cv);
1900
1901     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1902                                            : CvFILE(proto);
1903     CvGV_set(cv,CvGV(proto));
1904     CvSTASH_set(cv, CvSTASH(proto));
1905     OP_REFCNT_LOCK;
1906     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1907     OP_REFCNT_UNLOCK;
1908     CvSTART(cv)         = CvSTART(proto);
1909     CvOUTSIDE(cv)       = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1910     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1911
1912     if (SvPOK(proto))
1913         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1914
1915     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1916
1917     av_fill(PL_comppad, fpad);
1918     for (ix = fname; ix > 0; ix--)
1919         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1920
1921     PL_curpad = AvARRAY(PL_comppad);
1922
1923     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1924
1925     for (ix = fpad; ix > 0; ix--) {
1926         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1927         SV *sv = NULL;
1928         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1929             if (SvFAKE(namesv)) {   /* lexical from outside? */
1930                 sv = outpad[PARENT_PAD_INDEX(namesv)];
1931                 assert(sv);
1932                 /* formats may have an inactive parent,
1933                    while my $x if $false can leave an active var marked as
1934                    stale. And state vars are always available */
1935                 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1936                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1937                                    "Variable \"%"SVf"\" is not available", namesv);
1938                     sv = NULL;
1939                 }
1940                 else 
1941                     SvREFCNT_inc_simple_void_NN(sv);
1942             }
1943             if (!sv) {
1944                 const char sigil = SvPVX_const(namesv)[0];
1945                 if (sigil == '&')
1946                     sv = SvREFCNT_inc(ppad[ix]);
1947                 else if (sigil == '@')
1948                     sv = MUTABLE_SV(newAV());
1949                 else if (sigil == '%')
1950                     sv = MUTABLE_SV(newHV());
1951                 else
1952                     sv = newSV(0);
1953                 SvPADMY_on(sv);
1954                 /* reset the 'assign only once' flag on each state var */
1955                 if (SvPAD_STATE(namesv))
1956                     SvPADSTALE_on(sv);
1957             }
1958         }
1959         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1960             sv = SvREFCNT_inc_NN(ppad[ix]);
1961         }
1962         else {
1963             sv = newSV(0);
1964             SvPADTMP_on(sv);
1965         }
1966         PL_curpad[ix] = sv;
1967     }
1968
1969     DEBUG_Xv(
1970         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1971         cv_dump(outside, "Outside");
1972         cv_dump(proto,   "Proto");
1973         cv_dump(cv,      "To");
1974     );
1975
1976     LEAVE;
1977
1978     if (CvCONST(cv)) {
1979         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1980          * The prototype was marked as a candiate for const-ization,
1981          * so try to grab the current const value, and if successful,
1982          * turn into a const sub:
1983          */
1984         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1985         if (const_sv) {
1986             SvREFCNT_dec(cv);
1987             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1988         }
1989         else {
1990             CvCONST_off(cv);
1991         }
1992     }
1993
1994     return cv;
1995 }
1996
1997 /*
1998 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
1999
2000 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2001 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2002 moved to a pre-existing CV struct.
2003
2004 =cut
2005 */
2006
2007 void
2008 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2009 {
2010     dVAR;
2011     I32 ix;
2012     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2013     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2014     SV ** const namepad = AvARRAY(comppad_name);
2015     SV ** const curpad = AvARRAY(comppad);
2016
2017     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2018     PERL_UNUSED_ARG(old_cv);
2019
2020     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2021         const SV * const namesv = namepad[ix];
2022         if (namesv && namesv != &PL_sv_undef
2023             && *SvPVX_const(namesv) == '&')
2024         {
2025             CV * const innercv = MUTABLE_CV(curpad[ix]);
2026             assert(CvWEAKOUTSIDE(innercv));
2027             assert(CvOUTSIDE(innercv) == old_cv);
2028             CvOUTSIDE(innercv) = new_cv;
2029         }
2030     }
2031 }
2032
2033 /*
2034 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2035
2036 Push a new pad frame onto the padlist, unless there's already a pad at
2037 this depth, in which case don't bother creating a new one.  Then give
2038 the new pad an @_ in slot zero.
2039
2040 =cut
2041 */
2042
2043 void
2044 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2045 {
2046     dVAR;
2047
2048     PERL_ARGS_ASSERT_PAD_PUSH;
2049
2050     if (depth > AvFILLp(padlist)) {
2051         SV** const svp = AvARRAY(padlist);
2052         AV* const newpad = newAV();
2053         SV** const oldpad = AvARRAY(svp[depth-1]);
2054         I32 ix = AvFILLp((const AV *)svp[1]);
2055         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2056         SV** const names = AvARRAY(svp[0]);
2057         AV *av;
2058
2059         for ( ;ix > 0; ix--) {
2060             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2061                 const char sigil = SvPVX_const(names[ix])[0];
2062                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2063                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2064                         || sigil == '&')
2065                 {
2066                     /* outer lexical or anon code */
2067                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2068                 }
2069                 else {          /* our own lexical */
2070                     SV *sv; 
2071                     if (sigil == '@')
2072                         sv = MUTABLE_SV(newAV());
2073                     else if (sigil == '%')
2074                         sv = MUTABLE_SV(newHV());
2075                     else
2076                         sv = newSV(0);
2077                     av_store(newpad, ix, sv);
2078                     SvPADMY_on(sv);
2079                 }
2080             }
2081             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2082                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2083             }
2084             else {
2085                 /* save temporaries on recursion? */
2086                 SV * const sv = newSV(0);
2087                 av_store(newpad, ix, sv);
2088                 SvPADTMP_on(sv);
2089             }
2090         }
2091         av = newAV();
2092         av_store(newpad, 0, MUTABLE_SV(av));
2093         AvREIFY_only(av);
2094
2095         av_store(padlist, depth, MUTABLE_SV(newpad));
2096         AvFILLp(padlist) = depth;
2097     }
2098 }
2099
2100 /*
2101 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2102
2103 Looks up the type of the lexical variable at position I<po> in the
2104 currently-compiling pad.  If the variable is typed, the stash of the
2105 class to which it is typed is returned.  If not, C<NULL> is returned.
2106
2107 =cut
2108 */
2109
2110 HV *
2111 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2112 {
2113     dVAR;
2114     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2115     if ( SvPAD_TYPED(*av) ) {
2116         return SvSTASH(*av);
2117     }
2118     return NULL;
2119 }
2120
2121 #if defined(USE_ITHREADS)
2122
2123 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2124
2125 /*
2126 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2127
2128 Duplicates a pad.
2129
2130 =cut
2131 */
2132
2133 AV *
2134 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2135 {
2136     AV *dstpad;
2137     PERL_ARGS_ASSERT_PADLIST_DUP;
2138
2139     if (!srcpad)
2140         return NULL;
2141
2142     if (param->flags & CLONEf_COPY_STACKS
2143         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2144         dstpad = av_dup_inc(srcpad, param);
2145         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2146     } else {
2147         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2148            to build anything other than the first level of pads.  */
2149
2150         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2151         AV *pad1;
2152         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2153         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2154         SV **oldpad = AvARRAY(srcpad1);
2155         SV **names;
2156         SV **pad1a;
2157         AV *args;
2158         /* Look for it in the table first, as the padlist may have ended up
2159            as an element of @DB::args (or theoretically even @_), so it may
2160            may have been cloned already.  It may also be there because of
2161            how Perl_sv_compile_2op() "works". :-(   */
2162         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2163
2164         if (dstpad)
2165             return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2166
2167         dstpad = newAV();
2168         ptr_table_store(PL_ptr_table, srcpad, dstpad);
2169         av_extend(dstpad, 1);
2170         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2171         names = AvARRAY(AvARRAY(dstpad)[0]);
2172
2173         pad1 = newAV();
2174
2175         av_extend(pad1, ix);
2176         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2177         pad1a = AvARRAY(pad1);
2178         AvFILLp(dstpad) = 1;
2179
2180         if (ix > -1) {
2181             AvFILLp(pad1) = ix;
2182
2183             for ( ;ix > 0; ix--) {
2184                 if (!oldpad[ix]) {
2185                     pad1a[ix] = NULL;
2186                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2187                     const char sigil = SvPVX_const(names[ix])[0];
2188                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2189                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2190                         || sigil == '&')
2191                         {
2192                             /* outer lexical or anon code */
2193                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2194                         }
2195                     else {              /* our own lexical */
2196                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2197                             /* This is a work around for how the current
2198                                implementation of ?{ } blocks in regexps
2199                                interacts with lexicals.  */
2200                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2201                         } else {
2202                             SV *sv; 
2203                             
2204                             if (sigil == '@')
2205                                 sv = MUTABLE_SV(newAV());
2206                             else if (sigil == '%')
2207                                 sv = MUTABLE_SV(newHV());
2208                             else
2209                                 sv = newSV(0);
2210                             pad1a[ix] = sv;
2211                             SvPADMY_on(sv);
2212                         }
2213                     }
2214                 }
2215                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2216                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2217                 }
2218                 else {
2219                     /* save temporaries on recursion? */
2220                     SV * const sv = newSV(0);
2221                     pad1a[ix] = sv;
2222
2223                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2224                        FIXTHAT before merging this branch.
2225                        (And I know how to) */
2226                     if (SvPADMY(oldpad[ix]))
2227                         SvPADMY_on(sv);
2228                     else
2229                         SvPADTMP_on(sv);
2230                 }
2231             }
2232
2233             if (oldpad[0]) {
2234                 args = newAV();                 /* Will be @_ */
2235                 AvREIFY_only(args);
2236                 pad1a[0] = (SV *)args;
2237             }
2238         }
2239     }
2240
2241     return dstpad;
2242 }
2243
2244 #endif /* USE_ITHREADS */
2245
2246 /*
2247  * Local variables:
2248  * c-indentation-style: bsd
2249  * c-basic-offset: 4
2250  * indent-tabs-mode: t
2251  * End:
2252  *
2253  * ex: set ts=8 sts=4 sw=4 noet:
2254  */