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