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