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