Fix broken links in perldelta
[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     const bool staleok = !!(flags & padadd_STALEOK);
1127
1128     PERL_ARGS_ASSERT_PAD_FINDLEX;
1129
1130     if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1131         Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1132                    (UV)flags);
1133     flags &= ~ padadd_STALEOK; /* one-shot flag */
1134
1135     *out_flags = 0;
1136
1137     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1138         "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1139                            PTR2UV(cv), (int)namelen, namepv, (int)seq,
1140         out_capture ? " capturing" : "" ));
1141
1142     /* first, search this pad */
1143
1144     if (padlist) { /* not an undef CV */
1145         I32 fake_offset = 0;
1146         const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
1147         SV * const * const name_svp = AvARRAY(nameav);
1148
1149         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1150             const SV * const namesv = name_svp[offset];
1151             if (namesv && namesv != &PL_sv_undef
1152                     && SvCUR(namesv) == namelen
1153                     && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1154                                     flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1155             {
1156                 if (SvFAKE(namesv)) {
1157                     fake_offset = offset; /* in case we don't find a real one */
1158                     continue;
1159                 }
1160                 /* is seq within the range _LOW to _HIGH ?
1161                  * This is complicated by the fact that PL_cop_seqmax
1162                  * may have wrapped around at some point */
1163                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1164                     continue; /* not yet introduced */
1165
1166                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1167                     /* in compiling scope */
1168                     if (
1169                         (seq >  COP_SEQ_RANGE_LOW(namesv))
1170                         ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1171                         : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1172                     )
1173                        break;
1174                 }
1175                 else if (
1176                     (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1177                     ?
1178                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
1179                         || seq <= COP_SEQ_RANGE_HIGH(namesv))
1180
1181                     :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
1182                          && seq <= COP_SEQ_RANGE_HIGH(namesv))
1183                 )
1184                 break;
1185             }
1186         }
1187
1188         if (offset > 0 || fake_offset > 0 ) { /* a match! */
1189             if (offset > 0) { /* not fake */
1190                 fake_offset = 0;
1191                 *out_name_sv = name_svp[offset]; /* return the namesv */
1192
1193                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1194                  * instances. For now, we just test !CvUNIQUE(cv), but
1195                  * ideally, we should detect my's declared within loops
1196                  * etc - this would allow a wider range of 'not stayed
1197                  * shared' warnings. We also treated already-compiled
1198                  * lexes as not multi as viewed from evals. */
1199
1200                 *out_flags = CvANON(cv) ?
1201                         PAD_FAKELEX_ANON :
1202                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1203                                 ? PAD_FAKELEX_MULTI : 0;
1204
1205                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1206                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1207                     PTR2UV(cv), (long)offset,
1208                     (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1209                     (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1210             }
1211             else { /* fake match */
1212                 offset = fake_offset;
1213                 *out_name_sv = name_svp[offset]; /* return the namesv */
1214                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1215                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1216                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1217                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1218                     (unsigned long) PARENT_PAD_INDEX(*out_name_sv) 
1219                 ));
1220             }
1221
1222             /* return the lex? */
1223
1224             if (out_capture) {
1225
1226                 /* our ? */
1227                 if (SvPAD_OUR(*out_name_sv)) {
1228                     *out_capture = NULL;
1229                     return offset;
1230                 }
1231
1232                 /* trying to capture from an anon prototype? */
1233                 if (CvCOMPILED(cv)
1234                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1235                         : *out_flags & PAD_FAKELEX_ANON)
1236                 {
1237                     if (warn)
1238                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1239                                        "Variable \"%"SVf"\" is not available",
1240                                        newSVpvn_flags(namepv, namelen,
1241                                            SVs_TEMP |
1242                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1243
1244                     *out_capture = NULL;
1245                 }
1246
1247                 /* real value */
1248                 else {
1249                     int newwarn = warn;
1250                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1251                          && !SvPAD_STATE(name_svp[offset])
1252                          && warn && ckWARN(WARN_CLOSURE)) {
1253                         newwarn = 0;
1254                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1255                             "Variable \"%"SVf"\" will not stay shared",
1256                             newSVpvn_flags(namepv, namelen,
1257                                 SVs_TEMP |
1258                                 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1259                     }
1260
1261                     if (fake_offset && CvANON(cv)
1262                             && CvCLONE(cv) &&!CvCLONED(cv))
1263                     {
1264                         SV *n;
1265                         /* not yet caught - look further up */
1266                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1267                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1268                             PTR2UV(cv)));
1269                         n = *out_name_sv;
1270                         (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1271                             CvOUTSIDE_SEQ(cv),
1272                             newwarn, out_capture, out_name_sv, out_flags);
1273                         *out_name_sv = n;
1274                         return offset;
1275                     }
1276
1277                     *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1278                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
1279                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1280                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1281                         PTR2UV(cv), PTR2UV(*out_capture)));
1282
1283                     if (SvPADSTALE(*out_capture)
1284                         && (!CvDEPTH(cv) || !staleok)
1285                         && !SvPAD_STATE(name_svp[offset]))
1286                     {
1287                         Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1288                                        "Variable \"%"SVf"\" is not available",
1289                                        newSVpvn_flags(namepv, namelen,
1290                                            SVs_TEMP |
1291                                            (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1292                         *out_capture = NULL;
1293                     }
1294                 }
1295                 if (!*out_capture) {
1296                     if (namelen != 0 && *namepv == '@')
1297                         *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1298                     else if (namelen != 0 && *namepv == '%')
1299                         *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1300                     else
1301                         *out_capture = sv_newmortal();
1302                 }
1303             }
1304
1305             return offset;
1306         }
1307     }
1308
1309     /* it's not in this pad - try above */
1310
1311     if (!CvOUTSIDE(cv))
1312         return NOT_IN_PAD;
1313
1314     /* out_capture non-null means caller wants us to capture lex; in
1315      * addition we capture ourselves unless it's an ANON/format */
1316     new_capturep = out_capture ? out_capture :
1317                 CvLATE(cv) ? NULL : &new_capture;
1318
1319     offset = pad_findlex(namepv, namelen,
1320                 flags | padadd_STALEOK*(new_capturep == &new_capture),
1321                 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1322                 new_capturep, out_name_sv, out_flags);
1323     if ((PADOFFSET)offset == NOT_IN_PAD)
1324         return NOT_IN_PAD;
1325
1326     /* found in an outer CV. Add appropriate fake entry to this pad */
1327
1328     /* don't add new fake entries (via eval) to CVs that we have already
1329      * finished compiling, or to undef CVs */
1330     if (CvCOMPILED(cv) || !padlist)
1331         return 0; /* this dummy (and invalid) value isnt used by the caller */
1332
1333     {
1334         /* This relies on sv_setsv_flags() upgrading the destination to the same
1335            type as the source, independent of the flags set, and on it being
1336            "good" and only copying flag bits and pointers that it understands.
1337         */
1338         SV *new_namesv = newSVsv(*out_name_sv);
1339         AV *  const ocomppad_name = PL_comppad_name;
1340         PAD * const ocomppad = PL_comppad;
1341         PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1342         PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1343         PL_curpad = AvARRAY(PL_comppad);
1344
1345         new_offset
1346             = pad_alloc_name(new_namesv,
1347                               (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1348                               SvPAD_TYPED(*out_name_sv)
1349                               ? SvSTASH(*out_name_sv) : NULL,
1350                               SvOURSTASH(*out_name_sv)
1351                               );
1352
1353         SvFAKE_on(new_namesv);
1354         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1355                                "Pad addname: %ld \"%.*s\" FAKE\n",
1356                                (long)new_offset,
1357                                (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1358         PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1359
1360         PARENT_PAD_INDEX_set(new_namesv, 0);
1361         if (SvPAD_OUR(new_namesv)) {
1362             NOOP;   /* do nothing */
1363         }
1364         else if (CvLATE(cv)) {
1365             /* delayed creation - just note the offset within parent pad */
1366             PARENT_PAD_INDEX_set(new_namesv, offset);
1367             CvCLONE_on(cv);
1368         }
1369         else {
1370             /* immediate creation - capture outer value right now */
1371             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1372             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1373                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1374                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1375         }
1376         *out_name_sv = new_namesv;
1377         *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1378
1379         PL_comppad_name = ocomppad_name;
1380         PL_comppad = ocomppad;
1381         PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1382     }
1383     return new_offset;
1384 }
1385
1386 #ifdef DEBUGGING
1387
1388 /*
1389 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1390
1391 Get the value at offset I<po> in the current (compiling or executing) pad.
1392 Use macro PAD_SV instead of calling this function directly.
1393
1394 =cut
1395 */
1396
1397 SV *
1398 Perl_pad_sv(pTHX_ PADOFFSET po)
1399 {
1400     dVAR;
1401     ASSERT_CURPAD_ACTIVE("pad_sv");
1402
1403     if (!po)
1404         Perl_croak(aTHX_ "panic: pad_sv po");
1405     DEBUG_X(PerlIO_printf(Perl_debug_log,
1406         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
1407         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1408     );
1409     return PL_curpad[po];
1410 }
1411
1412 /*
1413 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1414
1415 Set the value at offset I<po> in the current (compiling or executing) pad.
1416 Use the macro PAD_SETSV() rather than calling this function directly.
1417
1418 =cut
1419 */
1420
1421 void
1422 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1423 {
1424     dVAR;
1425
1426     PERL_ARGS_ASSERT_PAD_SETSV;
1427
1428     ASSERT_CURPAD_ACTIVE("pad_setsv");
1429
1430     DEBUG_X(PerlIO_printf(Perl_debug_log,
1431         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
1432         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1433     );
1434     PL_curpad[po] = sv;
1435 }
1436
1437 #endif /* DEBUGGING */
1438
1439 /*
1440 =for apidoc m|void|pad_block_start|int full
1441
1442 Update the pad compilation state variables on entry to a new block
1443
1444 =cut
1445 */
1446
1447 /* XXX DAPM perhaps:
1448  *      - integrate this in general state-saving routine ???
1449  *      - combine with the state-saving going on in pad_new ???
1450  *      - introduce a new SAVE type that does all this in one go ?
1451  */
1452
1453 void
1454 Perl_pad_block_start(pTHX_ int full)
1455 {
1456     dVAR;
1457     ASSERT_CURPAD_ACTIVE("pad_block_start");
1458     SAVEI32(PL_comppad_name_floor);
1459     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1460     if (full)
1461         PL_comppad_name_fill = PL_comppad_name_floor;
1462     if (PL_comppad_name_floor < 0)
1463         PL_comppad_name_floor = 0;
1464     SAVEI32(PL_min_intro_pending);
1465     SAVEI32(PL_max_intro_pending);
1466     PL_min_intro_pending = 0;
1467     SAVEI32(PL_comppad_name_fill);
1468     SAVEI32(PL_padix_floor);
1469     PL_padix_floor = PL_padix;
1470     PL_pad_reset_pending = FALSE;
1471 }
1472
1473 /*
1474 =for apidoc m|U32|intro_my
1475
1476 "Introduce" my variables to visible status.  This is called during parsing
1477 at the end of each statement to make lexical variables visible to
1478 subsequent statements.
1479
1480 =cut
1481 */
1482
1483 U32
1484 Perl_intro_my(pTHX)
1485 {
1486     dVAR;
1487     SV **svp;
1488     I32 i;
1489     U32 seq;
1490
1491     ASSERT_CURPAD_ACTIVE("intro_my");
1492     if (! PL_min_intro_pending)
1493         return PL_cop_seqmax;
1494
1495     svp = AvARRAY(PL_comppad_name);
1496     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1497         SV * const sv = svp[i];
1498
1499         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1500             && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1501         {
1502             COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1503             COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1504             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1505                 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1506                 (long)i, SvPVX_const(sv),
1507                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1508                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1509             );
1510         }
1511     }
1512     seq = PL_cop_seqmax;
1513     PL_cop_seqmax++;
1514     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1515         PL_cop_seqmax++;
1516     PL_min_intro_pending = 0;
1517     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1518     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1519                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1520
1521     return seq;
1522 }
1523
1524 /*
1525 =for apidoc m|void|pad_leavemy
1526
1527 Cleanup at end of scope during compilation: set the max seq number for
1528 lexicals in this scope and warn of any lexicals that never got introduced.
1529
1530 =cut
1531 */
1532
1533 void
1534 Perl_pad_leavemy(pTHX)
1535 {
1536     dVAR;
1537     I32 off;
1538     SV * const * const svp = AvARRAY(PL_comppad_name);
1539
1540     PL_pad_reset_pending = FALSE;
1541
1542     ASSERT_CURPAD_ACTIVE("pad_leavemy");
1543     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1544         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1545             const SV * const sv = svp[off];
1546             if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1547                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1548                                  "%"SVf" never introduced",
1549                                  SVfARG(sv));
1550         }
1551     }
1552     /* "Deintroduce" my variables that are leaving with this scope. */
1553     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1554         const SV * const sv = svp[off];
1555         if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1556             && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1557         {
1558             COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1559             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1560                 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1561                 (long)off, SvPVX_const(sv),
1562                 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1563                 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1564             );
1565         }
1566     }
1567     PL_cop_seqmax++;
1568     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1569         PL_cop_seqmax++;
1570     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1571             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1572 }
1573
1574 /*
1575 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1576
1577 Abandon the tmp in the current pad at offset po and replace with a
1578 new one.
1579
1580 =cut
1581 */
1582
1583 void
1584 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1585 {
1586     dVAR;
1587     ASSERT_CURPAD_LEGAL("pad_swipe");
1588     if (!PL_curpad)
1589         return;
1590     if (AvARRAY(PL_comppad) != PL_curpad)
1591         Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1592                    AvARRAY(PL_comppad), PL_curpad);
1593     if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1594         Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1595                    (long)po, (long)AvFILLp(PL_comppad));
1596
1597     DEBUG_X(PerlIO_printf(Perl_debug_log,
1598                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1599                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1600
1601     if (PL_curpad[po])
1602         SvPADTMP_off(PL_curpad[po]);
1603     if (refadjust)
1604         SvREFCNT_dec(PL_curpad[po]);
1605
1606
1607     /* if pad tmps aren't shared between ops, then there's no need to
1608      * create a new tmp when an existing op is freed */
1609 #ifdef USE_BROKEN_PAD_RESET
1610     PL_curpad[po] = newSV(0);
1611     SvPADTMP_on(PL_curpad[po]);
1612 #else
1613     PL_curpad[po] = &PL_sv_undef;
1614 #endif
1615     if ((I32)po < PL_padix)
1616         PL_padix = po - 1;
1617 }
1618
1619 /*
1620 =for apidoc m|void|pad_reset
1621
1622 Mark all the current temporaries for reuse
1623
1624 =cut
1625 */
1626
1627 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1628  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1629  * on the stack by OPs that use them, there are several ways to get an alias
1630  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1631  * We avoid doing this until we can think of a Better Way.
1632  * GSAR 97-10-29 */
1633 static void
1634 S_pad_reset(pTHX)
1635 {
1636     dVAR;
1637 #ifdef USE_BROKEN_PAD_RESET
1638     if (AvARRAY(PL_comppad) != PL_curpad)
1639         Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1640                    AvARRAY(PL_comppad), PL_curpad);
1641
1642     DEBUG_X(PerlIO_printf(Perl_debug_log,
1643             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1644             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1645                 (long)PL_padix, (long)PL_padix_floor
1646             )
1647     );
1648
1649     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1650         register I32 po;
1651         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1652             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1653                 SvPADTMP_off(PL_curpad[po]);
1654         }
1655         PL_padix = PL_padix_floor;
1656     }
1657 #endif
1658     PL_pad_reset_pending = FALSE;
1659 }
1660
1661 /*
1662 =for apidoc Amx|void|pad_tidy|padtidy_type type
1663
1664 Tidy up a pad at the end of compilation of the code to which it belongs.
1665 Jobs performed here are: remove most stuff from the pads of anonsub
1666 prototypes; give it a @_; mark temporaries as such.  I<type> indicates
1667 the kind of subroutine:
1668
1669     padtidy_SUB        ordinary subroutine
1670     padtidy_SUBCLONE   prototype for lexical closure
1671     padtidy_FORMAT     format
1672
1673 =cut
1674 */
1675
1676 /* XXX DAPM surely most of this stuff should be done properly
1677  * at the right time beforehand, rather than going around afterwards
1678  * cleaning up our mistakes ???
1679  */
1680
1681 void
1682 Perl_pad_tidy(pTHX_ padtidy_type type)
1683 {
1684     dVAR;
1685
1686     ASSERT_CURPAD_ACTIVE("pad_tidy");
1687
1688     /* If this CV has had any 'eval-capable' ops planted in it
1689      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1690      * anon prototypes in the chain of CVs should be marked as cloneable,
1691      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1692      * the right CvOUTSIDE.
1693      * If running with -d, *any* sub may potentially have an eval
1694      * executed within it.
1695      */
1696
1697     if (PL_cv_has_eval || PL_perldb) {
1698         const CV *cv;
1699         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1700             if (cv != PL_compcv && CvCOMPILED(cv))
1701                 break; /* no need to mark already-compiled code */
1702             if (CvANON(cv)) {
1703                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1704                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1705                 CvCLONE_on(cv);
1706                 CvHASEVAL_on(cv);
1707             }
1708         }
1709     }
1710
1711     /* extend curpad to match namepad */
1712     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1713         av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1714
1715     if (type == padtidy_SUBCLONE) {
1716         SV * const * const namep = AvARRAY(PL_comppad_name);
1717         PADOFFSET ix;
1718
1719         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1720             SV *namesv;
1721
1722             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1723                 continue;
1724             /*
1725              * The only things that a clonable function needs in its
1726              * pad are anonymous subs.
1727              * The rest are created anew during cloning.
1728              */
1729             if (!((namesv = namep[ix]) != NULL &&
1730                   namesv != &PL_sv_undef &&
1731                    *SvPVX_const(namesv) == '&'))
1732             {
1733                 SvREFCNT_dec(PL_curpad[ix]);
1734                 PL_curpad[ix] = NULL;
1735             }
1736         }
1737     }
1738     else if (type == padtidy_SUB) {
1739         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1740         AV * const av = newAV();                        /* Will be @_ */
1741         av_store(PL_comppad, 0, MUTABLE_SV(av));
1742         AvREIFY_only(av);
1743     }
1744
1745     if (type == padtidy_SUB || type == padtidy_FORMAT) {
1746         SV * const * const namep = AvARRAY(PL_comppad_name);
1747         PADOFFSET ix;
1748         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1749             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1750                 continue;
1751             if (!SvPADMY(PL_curpad[ix])) {
1752                 SvPADTMP_on(PL_curpad[ix]);
1753             } else if (!SvFAKE(namep[ix])) {
1754                 /* This is a work around for how the current implementation of
1755                    ?{ } blocks in regexps interacts with lexicals.
1756
1757                    One of our lexicals.
1758                    Can't do this on all lexicals, otherwise sub baz() won't
1759                    compile in
1760
1761                    my $foo;
1762
1763                    sub bar { ++$foo; }
1764
1765                    sub baz { ++$foo; }
1766
1767                    because completion of compiling &bar calling pad_tidy()
1768                    would cause (top level) $foo to be marked as stale, and
1769                    "no longer available".  */
1770                 SvPADSTALE_on(PL_curpad[ix]);
1771             }
1772         }
1773     }
1774     PL_curpad = AvARRAY(PL_comppad);
1775 }
1776
1777 /*
1778 =for apidoc m|void|pad_free|PADOFFSET po
1779
1780 Free the SV at offset po in the current pad.
1781
1782 =cut
1783 */
1784
1785 /* XXX DAPM integrate with pad_swipe ???? */
1786 void
1787 Perl_pad_free(pTHX_ PADOFFSET po)
1788 {
1789     dVAR;
1790     ASSERT_CURPAD_LEGAL("pad_free");
1791     if (!PL_curpad)
1792         return;
1793     if (AvARRAY(PL_comppad) != PL_curpad)
1794         Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1795                    AvARRAY(PL_comppad), PL_curpad);
1796     if (!po)
1797         Perl_croak(aTHX_ "panic: pad_free po");
1798
1799     DEBUG_X(PerlIO_printf(Perl_debug_log,
1800             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1801             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1802     );
1803
1804     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1805         SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1806     }
1807     if ((I32)po < PL_padix)
1808         PL_padix = po - 1;
1809 }
1810
1811 /*
1812 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1813
1814 Dump the contents of a padlist
1815
1816 =cut
1817 */
1818
1819 void
1820 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1821 {
1822     dVAR;
1823     const AV *pad_name;
1824     const AV *pad;
1825     SV **pname;
1826     SV **ppad;
1827     I32 ix;
1828
1829     PERL_ARGS_ASSERT_DO_DUMP_PAD;
1830
1831     if (!padlist) {
1832         return;
1833     }
1834     pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1835     pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1836     pname = AvARRAY(pad_name);
1837     ppad = AvARRAY(pad);
1838     Perl_dump_indent(aTHX_ level, file,
1839             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1840             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1841     );
1842
1843     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1844         const SV *namesv = pname[ix];
1845         if (namesv && namesv == &PL_sv_undef) {
1846             namesv = NULL;
1847         }
1848         if (namesv) {
1849             if (SvFAKE(namesv))
1850                 Perl_dump_indent(aTHX_ level+1, file,
1851                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1852                     (int) ix,
1853                     PTR2UV(ppad[ix]),
1854                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1855                     SvPVX_const(namesv),
1856                     (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1857                     (unsigned long)PARENT_PAD_INDEX(namesv)
1858
1859                 );
1860             else
1861                 Perl_dump_indent(aTHX_ level+1, file,
1862                     "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1863                     (int) ix,
1864                     PTR2UV(ppad[ix]),
1865                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1866                     (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1867                     (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1868                     SvPVX_const(namesv)
1869                 );
1870         }
1871         else if (full) {
1872             Perl_dump_indent(aTHX_ level+1, file,
1873                 "%2d. 0x%"UVxf"<%lu>\n",
1874                 (int) ix,
1875                 PTR2UV(ppad[ix]),
1876                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1877             );
1878         }
1879     }
1880 }
1881
1882 #ifdef DEBUGGING
1883
1884 /*
1885 =for apidoc m|void|cv_dump|CV *cv|const char *title
1886
1887 dump the contents of a CV
1888
1889 =cut
1890 */
1891
1892 STATIC void
1893 S_cv_dump(pTHX_ const CV *cv, const char *title)
1894 {
1895     dVAR;
1896     const CV * const outside = CvOUTSIDE(cv);
1897     AV* const padlist = CvPADLIST(cv);
1898
1899     PERL_ARGS_ASSERT_CV_DUMP;
1900
1901     PerlIO_printf(Perl_debug_log,
1902                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1903                   title,
1904                   PTR2UV(cv),
1905                   (CvANON(cv) ? "ANON"
1906                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1907                    : (cv == PL_main_cv) ? "MAIN"
1908                    : CvUNIQUE(cv) ? "UNIQUE"
1909                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1910                   PTR2UV(outside),
1911                   (!outside ? "null"
1912                    : CvANON(outside) ? "ANON"
1913                    : (outside == PL_main_cv) ? "MAIN"
1914                    : CvUNIQUE(outside) ? "UNIQUE"
1915                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1916
1917     PerlIO_printf(Perl_debug_log,
1918                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1919     do_dump_pad(1, Perl_debug_log, padlist, 1);
1920 }
1921
1922 #endif /* DEBUGGING */
1923
1924 /*
1925 =for apidoc Am|CV *|cv_clone|CV *proto
1926
1927 Clone a CV, making a lexical closure.  I<proto> supplies the prototype
1928 of the function: its code, pad structure, and other attributes.
1929 The prototype is combined with a capture of outer lexicals to which the
1930 code refers, which are taken from the currently-executing instance of
1931 the immediately surrounding code.
1932
1933 =cut
1934 */
1935
1936 CV *
1937 Perl_cv_clone(pTHX_ CV *proto)
1938 {
1939     dVAR;
1940     I32 ix;
1941     AV* const protopadlist = CvPADLIST(proto);
1942     const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1943     const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1944     SV** const pname = AvARRAY(protopad_name);
1945     SV** const ppad = AvARRAY(protopad);
1946     const I32 fname = AvFILLp(protopad_name);
1947     const I32 fpad = AvFILLp(protopad);
1948     CV* cv;
1949     SV** outpad;
1950     CV* outside;
1951     long depth;
1952
1953     PERL_ARGS_ASSERT_CV_CLONE;
1954
1955     assert(!CvUNIQUE(proto));
1956
1957     /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1958      * reliable.  The currently-running sub is always the one we need to
1959      * close over.
1960      * Note that in general for formats, CvOUTSIDE != find_runcv.
1961      * Since formats may be nested inside closures, CvOUTSIDE may point
1962      * to a prototype; we instead want the cloned parent who called us.
1963      */
1964
1965     if (SvTYPE(proto) == SVt_PVCV)
1966         outside = find_runcv(NULL);
1967     else {
1968         outside = CvOUTSIDE(proto);
1969         if (CvCLONE(outside) && ! CvCLONED(outside)) {
1970             CV * const runcv = find_runcv_where(
1971                 FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
1972             );
1973             if (runcv) outside = runcv;
1974         }
1975     }
1976     depth = CvDEPTH(outside);
1977     assert(depth || SvTYPE(proto) == SVt_PVFM);
1978     if (!depth)
1979         depth = 1;
1980     assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
1981
1982     ENTER;
1983     SAVESPTR(PL_compcv);
1984
1985     cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1986     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
1987                                     |CVf_SLABBED);
1988     CvCLONED_on(cv);
1989
1990     CvFILE(cv)          = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1991                                            : CvFILE(proto);
1992     CvGV_set(cv,CvGV(proto));
1993     CvSTASH_set(cv, CvSTASH(proto));
1994     OP_REFCNT_LOCK;
1995     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1996     OP_REFCNT_UNLOCK;
1997     CvSTART(cv)         = CvSTART(proto);
1998     if (CvHASEVAL(cv))
1999         CvOUTSIDE(cv)   = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2000     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2001
2002     if (SvPOK(proto))
2003         sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2004     if (SvMAGIC(proto))
2005         mg_copy((SV *)proto, (SV *)cv, 0, 0);
2006
2007     CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2008
2009     av_fill(PL_comppad, fpad);
2010     for (ix = fname; ix > 0; ix--)
2011         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
2012
2013     PL_curpad = AvARRAY(PL_comppad);
2014
2015     outpad = CvPADLIST(outside)
2016         ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
2017         : NULL;
2018     assert(outpad || SvTYPE(cv) == SVt_PVFM);
2019
2020     for (ix = fpad; ix > 0; ix--) {
2021         SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2022         SV *sv = NULL;
2023         if (namesv && namesv != &PL_sv_undef) { /* lexical */
2024             if (SvFAKE(namesv)) {   /* lexical from outside? */
2025                 /* formats may have an inactive, or even undefined, parent;
2026                    but state vars are always available. */
2027                 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2028                  || (  SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2029                     && !CvDEPTH(outside))  ) {
2030                     assert(SvTYPE(cv) == SVt_PVFM);
2031                     Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
2032                                    "Variable \"%"SVf"\" is not available", namesv);
2033                     sv = NULL;
2034                 }
2035                 else 
2036                     SvREFCNT_inc_simple_void_NN(sv);
2037             }
2038             if (!sv) {
2039                 const char sigil = SvPVX_const(namesv)[0];
2040                 if (sigil == '&')
2041                     sv = SvREFCNT_inc(ppad[ix]);
2042                 else if (sigil == '@')
2043                     sv = MUTABLE_SV(newAV());
2044                 else if (sigil == '%')
2045                     sv = MUTABLE_SV(newHV());
2046                 else
2047                     sv = newSV(0);
2048                 SvPADMY_on(sv);
2049                 /* reset the 'assign only once' flag on each state var */
2050                 if (SvPAD_STATE(namesv))
2051                     SvPADSTALE_on(sv);
2052             }
2053         }
2054         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2055             sv = SvREFCNT_inc_NN(ppad[ix]);
2056         }
2057         else {
2058             sv = newSV(0);
2059             SvPADTMP_on(sv);
2060         }
2061         PL_curpad[ix] = sv;
2062     }
2063
2064     DEBUG_Xv(
2065         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2066         cv_dump(outside, "Outside");
2067         cv_dump(proto,   "Proto");
2068         cv_dump(cv,      "To");
2069     );
2070
2071     LEAVE;
2072
2073     if (CvCONST(cv)) {
2074         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2075          * The prototype was marked as a candiate for const-ization,
2076          * so try to grab the current const value, and if successful,
2077          * turn into a const sub:
2078          */
2079         SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2080         if (const_sv) {
2081             SvREFCNT_dec(cv);
2082             cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2083         }
2084         else {
2085             CvCONST_off(cv);
2086         }
2087     }
2088
2089     return cv;
2090 }
2091
2092 /*
2093 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2094
2095 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2096 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2097 moved to a pre-existing CV struct.
2098
2099 =cut
2100 */
2101
2102 void
2103 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2104 {
2105     dVAR;
2106     I32 ix;
2107     AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2108     AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
2109     SV ** const namepad = AvARRAY(comppad_name);
2110     SV ** const curpad = AvARRAY(comppad);
2111
2112     PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2113     PERL_UNUSED_ARG(old_cv);
2114
2115     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2116         const SV * const namesv = namepad[ix];
2117         if (namesv && namesv != &PL_sv_undef
2118             && *SvPVX_const(namesv) == '&')
2119         {
2120           if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2121             CV * const innercv = MUTABLE_CV(curpad[ix]);
2122             assert(CvWEAKOUTSIDE(innercv));
2123             assert(CvOUTSIDE(innercv) == old_cv);
2124             CvOUTSIDE(innercv) = new_cv;
2125           }
2126           else { /* format reference */
2127             SV * const rv = curpad[ix];
2128             CV *innercv;
2129             if (!SvOK(rv)) continue;
2130             assert(SvROK(rv));
2131             assert(SvWEAKREF(rv));
2132             innercv = (CV *)SvRV(rv);
2133             assert(!CvWEAKOUTSIDE(innercv));
2134             SvREFCNT_dec(CvOUTSIDE(innercv));
2135             CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2136           }
2137         }
2138     }
2139 }
2140
2141 /*
2142 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2143
2144 Push a new pad frame onto the padlist, unless there's already a pad at
2145 this depth, in which case don't bother creating a new one.  Then give
2146 the new pad an @_ in slot zero.
2147
2148 =cut
2149 */
2150
2151 void
2152 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2153 {
2154     dVAR;
2155
2156     PERL_ARGS_ASSERT_PAD_PUSH;
2157
2158     if (depth > AvFILLp(padlist)) {
2159         SV** const svp = AvARRAY(padlist);
2160         AV* const newpad = newAV();
2161         SV** const oldpad = AvARRAY(svp[depth-1]);
2162         I32 ix = AvFILLp((const AV *)svp[1]);
2163         const I32 names_fill = AvFILLp((const AV *)svp[0]);
2164         SV** const names = AvARRAY(svp[0]);
2165         AV *av;
2166
2167         for ( ;ix > 0; ix--) {
2168             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2169                 const char sigil = SvPVX_const(names[ix])[0];
2170                 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2171                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2172                         || sigil == '&')
2173                 {
2174                     /* outer lexical or anon code */
2175                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2176                 }
2177                 else {          /* our own lexical */
2178                     SV *sv; 
2179                     if (sigil == '@')
2180                         sv = MUTABLE_SV(newAV());
2181                     else if (sigil == '%')
2182                         sv = MUTABLE_SV(newHV());
2183                     else
2184                         sv = newSV(0);
2185                     av_store(newpad, ix, sv);
2186                     SvPADMY_on(sv);
2187                 }
2188             }
2189             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2190                 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2191             }
2192             else {
2193                 /* save temporaries on recursion? */
2194                 SV * const sv = newSV(0);
2195                 av_store(newpad, ix, sv);
2196                 SvPADTMP_on(sv);
2197             }
2198         }
2199         av = newAV();
2200         av_store(newpad, 0, MUTABLE_SV(av));
2201         AvREIFY_only(av);
2202
2203         av_store(padlist, depth, MUTABLE_SV(newpad));
2204         AvFILLp(padlist) = depth;
2205     }
2206 }
2207
2208 /*
2209 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2210
2211 Looks up the type of the lexical variable at position I<po> in the
2212 currently-compiling pad.  If the variable is typed, the stash of the
2213 class to which it is typed is returned.  If not, C<NULL> is returned.
2214
2215 =cut
2216 */
2217
2218 HV *
2219 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2220 {
2221     dVAR;
2222     SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2223     if ( SvPAD_TYPED(*av) ) {
2224         return SvSTASH(*av);
2225     }
2226     return NULL;
2227 }
2228
2229 #if defined(USE_ITHREADS)
2230
2231 #  define av_dup_inc(s,t)       MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2232
2233 /*
2234 =for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2235
2236 Duplicates a pad.
2237
2238 =cut
2239 */
2240
2241 AV *
2242 Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
2243 {
2244     AV *dstpad;
2245     PERL_ARGS_ASSERT_PADLIST_DUP;
2246
2247     if (!srcpad)
2248         return NULL;
2249
2250     if (param->flags & CLONEf_COPY_STACKS
2251         || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
2252         dstpad = av_dup_inc(srcpad, param);
2253         assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2254     } else {
2255         /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2256            to build anything other than the first level of pads.  */
2257
2258         I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2259         AV *pad1;
2260         const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
2261         const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2262         SV **oldpad = AvARRAY(srcpad1);
2263         SV **names;
2264         SV **pad1a;
2265         AV *args;
2266         /* Look for it in the table first, as the padlist may have ended up
2267            as an element of @DB::args (or theoretically even @_), so it may
2268            may have been cloned already. */
2269         dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2270
2271         if (dstpad)
2272             return (AV *)SvREFCNT_inc_simple_NN(dstpad);
2273
2274         dstpad = newAV();
2275         ptr_table_store(PL_ptr_table, srcpad, dstpad);
2276         av_extend(dstpad, 1);
2277         AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2278         names = AvARRAY(AvARRAY(dstpad)[0]);
2279
2280         pad1 = newAV();
2281
2282         av_extend(pad1, ix);
2283         AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2284         pad1a = AvARRAY(pad1);
2285         AvFILLp(dstpad) = 1;
2286
2287         if (ix > -1) {
2288             AvFILLp(pad1) = ix;
2289
2290             for ( ;ix > 0; ix--) {
2291                 if (!oldpad[ix]) {
2292                     pad1a[ix] = NULL;
2293                 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2294                     const char sigil = SvPVX_const(names[ix])[0];
2295                     if ((SvFLAGS(names[ix]) & SVf_FAKE)
2296                         || (SvFLAGS(names[ix]) & SVpad_STATE)
2297                         || sigil == '&')
2298                         {
2299                             /* outer lexical or anon code */
2300                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2301                         }
2302                     else {              /* our own lexical */
2303                         if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2304                             /* This is a work around for how the current
2305                                implementation of ?{ } blocks in regexps
2306                                interacts with lexicals.  */
2307                             pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2308                         } else {
2309                             SV *sv; 
2310                             
2311                             if (sigil == '@')
2312                                 sv = MUTABLE_SV(newAV());
2313                             else if (sigil == '%')
2314                                 sv = MUTABLE_SV(newHV());
2315                             else
2316                                 sv = newSV(0);
2317                             pad1a[ix] = sv;
2318                             SvPADMY_on(sv);
2319                         }
2320                     }
2321                 }
2322                 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2323                     pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2324                 }
2325                 else {
2326                     /* save temporaries on recursion? */
2327                     SV * const sv = newSV(0);
2328                     pad1a[ix] = sv;
2329
2330                     /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2331                        FIXTHAT before merging this branch.
2332                        (And I know how to) */
2333                     if (SvPADMY(oldpad[ix]))
2334                         SvPADMY_on(sv);
2335                     else
2336                         SvPADTMP_on(sv);
2337                 }
2338             }
2339
2340             if (oldpad[0]) {
2341                 args = newAV();                 /* Will be @_ */
2342                 AvREIFY_only(args);
2343                 pad1a[0] = (SV *)args;
2344             }
2345         }
2346     }
2347
2348     return dstpad;
2349 }
2350
2351 #endif /* USE_ITHREADS */
2352
2353 /*
2354  * Local variables:
2355  * c-indentation-style: bsd
2356  * c-basic-offset: 4
2357  * indent-tabs-mode: nil
2358  * End:
2359  *
2360  * ex: set ts=8 sts=4 sw=4 et:
2361  */