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