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